{$J+} unit U_BaseCommon; interface uses Forms, StdCtrls, Classes, ComCtrls, Windows, Controls, Contnrs, Messages, Math, DrawEngine, PCTypesUtils, SysUtils, Dialogs, DrawObjects, PCDrawBox, PCDrawing, PowerCad, Graphics, pFIBDatabase, FIBQuery, pFIBQuery, pFIBDataSet, pFIBProps, fib, kbmMemTable, U_ESCadclasess, U_HouseClasses, DB, ibase, SQLMemMain, cxTextEdit, cxEdit, cxMemo, cxGridCustomTableView, cxGridDBTableView, cxSpinEdit, cxMaskEdit, cxImage, cxGridLevel, cxDropDownEdit, cxGraphics, cxRadioGroup, cxCurrencyEdit, RzTabs, RzTreeVw, RzListVw, RzBHints, Buttons, RzEdit, RzButton, RzRadChk, DateUtils, ExtCtrls, idGlobal, IdGlobalProtocols{, IdWinsock}, Winsock, Variants, ActiveX, ShlObj, Menus, ActnList, exgrid, RapTree, FlytreePro, Treecoll, IsPlugEdit, ispinedit, ShellApi, IniFiles, Registry, TypInfo, PDF, {bz2,} U_SCSLists, U_TrunkSCS, U_BaseConstants, U_Constants, Consts, U_AnswerToQuast{Tolik 24/03/2017 -- навигатор}, U_Navigator {//06.05.2013 ДЛЯ GESHintWindow: TESHintWindow} , IdHTTP; // ################## Types & Constants for NormBase ########################### // ############################################################################# // const IsUseProjLoginning = true; fatrReadOnly = $00000001 platform; fatrHidden = $00000002 platform; fatrSysFile = $00000004 platform; fatrVolumeID = $00000008 platform; fatrDirectory = $00000010; fatrArchive = $00000020 platform; fatrAnyFile = $0000003F; // Cursors crHandFingers = 129; crHandFist = 130; // Current Buid //21.08.2012 CurrentNBBuildID = 36; добавыление поля ISMARK_IN_CAPTIONS //22.10.2013 CurrentNBBuildID = 38; //23.01.2014 CurrentNBBuildID = 39; //22.10.2013 добавление полей стоимости нормы за время CurrentNBBuildID = 40; //22.09.2010 CurrentProjBuildID = 19; //05.10.2010 CurrentProjBuildID = 20;//22.09.2010 //14.12.2011 CurrentProjBuildID = 21; //05.10.2010 //21.08.2012 CurrentProjBuildID = 22; //25.10.2013 CurrentProjBuildID = 24; //21.08.2012 - определение флага IsMarkInCaptions //CurrentProjBuildID = 25; //25.10.2013 - добавление полей стоимости нормы за время CurrentProjBuildID = 26; // Эмбаркадеро с оптимизированной загрузкой растровых изображений ProjBuildIDWithStrMan = 14; ProjBuildIDWithRoomNameShort = 15; ProjBuildIDWithSaveInPlacing = 17; ProjBuildIDWithSaveComponDataInPlacing = 22; ProjBuildIDBeforeRaiseDrawFigure = 23; ProjBuildIDWithOptimizedRasterImageLoad = 26; // Tolik 31/01/2020 -- для проверки старых проектов, в // которых еще не выполнена оптимизация загрузки растровых изображений MaxGDIObjects = 45000; {$IF Defined(SCS_PE)} FloatPrecision = 2; {$ELSE} FloatPrecision = 3; {$IFEND} PrecisionNormKolvo = 5; ReservGuidSize = 5000; //ReservGuidSizeMin = 10000; // NB TYpes - типы нормативных баз nbtNone = 0; nbtGeneral = 1; // Общая nbtTrial = 2; // Триал nbtSCSUA = 3; nbtSCSRU = 4; nbtTelecomUA = 5; nbtTelecomRU = 6; nbTube = 7; nbCableProjectPE = 8; nbGraphStroyCalc = 9; // знач-е 10 спецово пропускаем nbtTelcoCAD = 11; // TelcoCAD {$IF Not Defined(FINAL_SCS)} CurrNBType = nbtGeneral; //CurrNBType = nbtSCSUA; {$ELSEIF Defined(TRIAL_SCS) and not Defined(PROCAT_SCS) and not Defined(SCS_PE)} {$IF Defined(ES_GRAPH_SC)} CurrNBType = nbGraphStroyCalc; {$ELSE} CurrNBType = nbtTrial; {$IFEND} {$ELSEIF Defined(TELECOM)} {$IF Defined(SCS_RF)} CurrNBType = nbtTelecomRU; //CurrNBType = nbtSCSRU; {$ELSE} CurrNBType = nbtTelecomUA; {$IFEND} {$ELSEIF Defined(TUBE)} CurrNBType = nbTube; {$ELSEIF Defined(SCS_PE) or Defined(SCS_PANDUIT)} CurrNBType = nbCableProjectPE; {$ELSEIF Defined(ES_GRAPH_SC)} CurrNBType = nbGraphStroyCalc; {$ELSEIF Defined(SCS_SPA)} CurrNBType = nbtTelcoCAD; {$ELSE} {$IF Defined(SCS_RF)} {$IF Defined(SCS_PANDUIT)} CurrNBType = nbCableProjectPE; {$ELSE} CurrNBType = nbtSCSRU; {$IFEND} {$ELSE} CurrNBType = nbtSCSUA; {$IFEND} {$IFEND} // Коэфф., где в базе (таблице tnGradeGrid, длине поля DESCRIPTION) сидит значение типа БД в виде CurrNBType * nbTypeKoeff nbTypeKoeff = 55; //*** TimerIDs TimerIDProjectSaveDateTime = 1; TimerIDProjectAutoSave = 2; TimerIDRefreshPMLockedTree = 3; TimerIDExpandNode = 4; TimerIDTreeViewScrolling = 5; // ##### ItemTypes ##### itNone = -1; itProjMan = 10; itDir = 0; itProject = 20; itRoom = 30; itList = 1; itSCSLine = 2; itSCSConnector = 3; itComponent = 4; itComponLine = 4; itComponCon = 5; itCommon = 6; itAuto = 7; itLinkCompLine = 13; itLinkCompCon = 14; itSCSLineGroup = 15; itSCSConnGroup = 16; itSCSEmptyGroup = 17; itArhContainer = 31; itArhRoom = 32; // Комната itArhWall = 33; // Стена itArhWallDivision = 34; // Перегородка itArhFloor = 35; // Пол itArhCeiling = 36; // Потолок itArhEmbrasure = 37; // Проем itArhWindow = 38; // Окно itArhDoor = 39; // Проем itArhNiche = 40; // Ниша itArhInnerSlope = 41; // Откос внутренний itArhOuterSlope = 42; // Откос внешний itArhArc = 43; // Арка itArhBalcony = 44; // Балкон itArhBrickWall = 45; // Кирпичная стена itArhWallCorner = 46; // Угол стены itArhRoof = 47; // Крыша itArhRoofSeg = 48; // Сегмент крыши itArhRoofHip = 49; // Ребро крыши itArhRoofHipCorner = 50; // Угол сегмента крыши // Directory Item Types ditNone = $000; ditComponentType = $001; ditCurrency = $002; ditInterface = $003; ditNBNorm = $004; ditNBResource = $005; ditNetType = $006; ditObjectIcon = $007; ditProducer = $008; ditProperty = $009; ditSuppliesKinds = $00A; ditUnitsOfMeasure = $00B; ditDimensions = $00C; ditCompSpecifications = $00D; const // Tree_catalog images indexes tciiProjMan = 0; tciiDir = 0; tciiDirOpened = 62; tciiProject = 29; tciiProjectClose = 30; tciiRoom = 31; tciiList = 1; tciiSCSLineNorm = 2; tciiSCSLineDif = 19; tciiSCSConNormal = 3; tciiSCSConUp = 15; tciiSCSConLo = 16; tciiSCSConFill = 21; tciiSCSConNoFill = 20; tciiSCSConPartFill = 22; tciiComponLine = 4; tciiComponLineFill = 24; tciiComponLineNoFill = 23; tciiComponLinePartFill = 25; tciiComponLineTemplate = 38; tciiComponCon = 5; tciiComponConFill = 27; tciiComponConNoFill = 26; tciiComponConPartFill = 28; tciiComponConTemplate = 39; tciiTemplateLine = 45; tciiTemplateCon = 46; tciiArchRoom = 47; tciiArchBrickWall = 48; tciiArchWall = 49; tciiArchWallDiv = 50; tciiArchDoor = 51; tciiArchWindow = 52; tciiArchNiche = 53; tciiArchArc = 54; tciiArchBalcony = 55; tciiArchFloor = 56; tciiArchInnerSlope = 57; tciiArhWallCorner = 58; //tciiArhRoof = 57; // Крыша tciiArhRoofSeg = 59; // Сегмент крыши tciiArhRoofHip = 60; // Ребро крыши tciiArhRoofHipCorner = 61; // Угол сегмента крыши tciiConnectedComponLineFill = 40; tciiConnectedComponLinePartFill = 41; tciiConnectedComponConFill = 42; tciiConnectedComponConPartFill = 43; tciiLinkCompLine = 13; tciiLinkCompCon = 14; tciiSCSLineGroup = 32; tciiSCSConnGroup = 33; tciiSCSEmptyGroup = 34; tciiInterface = 35; tciiInterfaceNoFill = 36; tciiInterfaceFill = 37; tciiConnectedInterface = 44; tciiCutDir = 6; tciiCutProject = 29; tciiCutList = 7; tciiCutRoom = 30; tciiCutSCSLineNorm = 8; tciiCutSCSLineDif = 19; tciiCutSCSConNormal = 9; tciiCutSCSConUp = 17; tciiCutSCSConLo = 18; tciiCutComponLine = 10; tciiCutComponCon = 11; tciiCutLinkCompLine = 13; tciiCutLinkCompCon = 14; // Tree Catalog State Index tcsiFavorite = 1; // Fly tree Botton Indexes tbiUnchecked = 0; tbiChecked = 1; tbiGrayed = 2; tbiCollapsed = 3; tbiExpanded = 4; BusyBaseTimeReserv = 10; //BusyBaseMode bbmEmpty = 0; bbmUpdate = 1; bbmExportData = 2; bbmImportData = 3; bbmPack = 4; bbmBackUp = 5; const // ObjectGroupType ogtEmpty = '{AFD577BA620C468E924430EDCFF65A07}'; //'0'; //ogtEmpty = 0; // ObjectGroupName // EpsilonForCurrency valEpsilonCurrency = 20; // Data Base Type DBType dbtNone = 0; dbtUsual = 1; dbtUpdate = 2; dbtCatalog = 3; dbtComponent = 4; const // CompData Level Index (TF_Main) cdliObjectCurrency = 0; cdliPort = 1; cdliComplects = 2; cdliProperty = 3; cdliInterface = 4; cdliConnections = 5; cdliCableChannelElements = 6; cdliCrossConnections = 7; cdliNormsResources = 8; // Colors clDisabledCell = $F4F4F4; // LangIndex lniEng = 0; lniRus = 1; lniUkr = 2; cntWorkDayHours = 8; // UnitOfMeasure - Длина // ВАЖНО!!!! - Значения констант менятся не должны, т.к. они хранятся на проектах umMillimetr = 1; umMM = umMillimetr; umSantimetr = 2; umSM = umSantimetr; umMetr = 3; umM = umMetr; umKiloMetr = 4; umKM = umKiloMetr; umInch = 5; umIn = umInch; umFoot = 6; umFt = umFoot; umMile = 7; umMi = umMile; // UnitOfMeasure - масса umGramm = 8; umGr = umGramm; umKilogramm = 9; umKg = umKilogramm; umCentner = 10; umCt = umCentner; umTonna = 11; umTn = umTonna; umOunce = 12; umOz = umOunce; umPound = 13; umLb = umPound; // UnitOfMeasureInMM ummSantimetr = 10; ummMetr = 100 * ummSantimetr; ummKiloMetr = 1000 * ummMetr; ummInch = 25.4; ummFoot = 12 * ummInch; //ummFootSpec = 304.878; ummFootSpec = 304.8; ummMile = 5280 * ummFoot; // Высота 1 Unit cUnitHeight = 0.044; //cUnitHeight = 0.0437; // CompData LevelIndexes (TF_AddComponent) liPort = 0; liInterface = 1; liProperty = 2; liComplects = 3; liCableCanalConnectors = 4; liCrossConnections = 5; // Dir Level for Currency dirCurrencyLevel = 1; // GridNorms FieldIndexes finIsOn = 1; const //*** Component Types //ctCable = 1; //ctSocket = 2; //ctWorkPlace = 5; //ctCableCanal = 6; //ctWire = 7; //// Провод //ctCork = 11; /// Заглушка //ctCupboard = 22; /// Шкаф //ctPatchCord = 12; //ctCrossPointObject = 26; ctCable = 1; ctSocket = 2; ctWorkPlace = 3; ctCableCanal = 4; ctCableChannelElement = 5; ctWire = 6; //// Провод ctCork = 7; /// Заглушка ctCupboard = 8; /// Шкаф ctPatchCord = 9; ctCrossPointObject = 10; // Path Type ptFrom = 1; ptTo = 2; ptWith = 3; //**** Component Type Sys Names ctsn19InchAccessory = '19INCH_ACCESSORY'; // 19" Аксессуар ctsnPCBFraming = 'PCB_FRAMING'; // PCB вставка ctsnNull = 'NULL'; // null ctsnAdapter = 'ADAPTER'; // Адаптер ctsnAdapterFraming = 'ADAPTER_ FRAMING '; // Адаптерная вставка ctsnAccessory = 'ACCESSORY'; // Аксессуар ctsnCableChannelAccessory = 'CABLE_CHANNEL_ACCESSORY'; // Аксессуар кабельного канала ctsnAnalyser = 'ANALYSER'; // Анализатор ctsnBox = 'BOX'; // Бокс ctsnOFCable = 'OF_CABLE'; // ВО кабель ctsnOFConnector = 'OF_CONNECTOR'; // ВО коннектор ctsnOFModule = 'OF_MODULE'; // ВО модуль ctsnTwoPinPlug = 'TWO_PIN_PLUG'; // Вилка ctsnPlugSwitch = 'PLUG_SWITCH'; // Выключатель ctsnOther = 'OTHER'; // Другое ctsnCork = 'CORK'; // Заглушка ctsnProtectionIU = 'PROTECTION_IU'; // Защита по I и U ctsnInstrument = 'INSTRUMENT'; // Инструмент ctsnInstrumentVSStandartAndVSModuler = 'INSTRUMENT_VS_STANDART_VS_MODULER'; // Инструмент VS Стандарт и VS Модуляр ctsnCable = 'CABLE'; // Кабель ctsnCableChannel = 'CABLE_CHANNEL'; // Кабельный канал ctsnConnectorBlock = 'CONNECTOR_BLOCK'; // Клеменная колодка ctsnConnector = 'CONNECTOR'; // Коннектор ctsnCase = 'CASE'; // Коробка ctsnCrossConnections = 'CROSS_CONNECTIONS'; // Кроссировка ctsnCrossPointObject = 'CROSS_POINT_OBJECT'; // Кроссо-точечный объект ctsnMetalConstruction = 'METAL_CONSTRUCTION'; // Металлоконструкции ctsnModule = 'MODULE'; // Модуль ctsnEquipment = 'EQUIPMENT'; // Оборудование ctsnOrganizer = 'ORGANIZER'; // Организатор ctsn19InchPanel = '19INCH_PANEL'; // Панель 19" ctsnPatchCord = 'PATCH_CORD'; // Патч корд ctsnPatchPanel = 'PATCH_PANEL'; // Патч панель ctsnTerminalBloc = 'TERMINAL_BLOC'; // Плинт ctsnWire = 'WIRE'; // Провод ctsnWorkPlace = 'WORK_PLACE'; // Рабочее место ctsnFrame = 'FRAME'; // Рамка ctsnSocket = 'SOCKET'; // Розетка ctsnJoiner = 'JOINER'; // Соединитель ctsnConnectingModule = 'CONNECTING_MODULE'; // Соединительный модуль ctsnTestingAccessory = 'TESTING_ACCESSORY'; // Тестирующие аксессуары ctsnTube = 'TUBE'; // Труба ctsnTubeElement = 'TUBE_ELEMENT'; // Tolik 13/10/2018 -- Элемент трубы, соединитель, сгон, муфта, поворотный уголок(2,3), крестовина и т.д. -- для соединения труб ctsnInstallBox = 'INSTALL_BOX'; // Установочный бокс ctsnCupboard = 'CUPBOARD'; // Шкаф ctsnJackPlug = 'JACKPLUG'; // Штекер ctsnShield = 'SHIELD'; // Щит ctsnCableChannelElement = 'CABLE_CHANNEL_ELEMENT'; // Элемент кабельного канала ctsnCrossATS = 'CROSS_ATS'; // Кросс-АТС ctsnDistributionCabinet = 'DISTRIBUTION_CABINET'; //Распределительный шкаф ctsnTerminalBox = 'TERMINAL_BOX'; //Распределительная коробка ctsnLamp = 'LAMP'; ctsnAutoSwitch = 'AUTO_SWITCH'; //Автоматический выключатель ctsnHouse = 'HOUSE'; // Дом ctsnApproach = 'APPROACH'; // Подъезд ctsnArhRoom = 'ARH_ROOM'; // Комната ctsnArhWall = 'ARH_WALL'; // Стена ctsnArhWallDivision = 'ARH_WALL_DIVISION'; // Перегородка ctsnArhFloor = 'ARH_FLOOR'; // Пол ctsnArhCeiling = 'ARH_CEILING'; // Потолок ctsnArhEmbrasure = 'ARH_EMBRASURE'; // Проем ctsnArhWindow = 'ARH_WINDOW'; // Проем ctsnArhDoor = 'ARH_DOOR'; // Проем ctsnArhNiche = 'ARH_NICHE'; // Ниша ctsnArhInnerSlope = 'ARH_INNER_SLOPE'; // Откос внутренний ctsnArhOuterSlope = 'ARH_OUTER_SLOPE'; // Откос внешний ctsnArhArc = 'ARH_ARC'; // Арка ctsnArhBalcony = 'ARH_BALCONY'; // Балкон ctsnArhBrickWall = 'ARH_BRICK_WALL'; // Балкон ctsnArhWallCorner = 'ARH_WALL_CORNER'; // Угол стены ctsnArhRoof = 'ARH_ROOF'; // Сегмент крыши ctsnArhRoofSeg = 'ARH_ROOF_SEG'; // Сегмент крыши ctsnArhRoofHip = 'ARH_ROOF_HIP'; // Ребро крыши ctsnArhRoofHipCorner = 'ARH_ROOF_HIP_CORNER'; // Угол сегмента крыши // Tolik 03/02/2021 -- для электрики ctsnVU = 'VU_EL'; // Вводное устройство ctsnVRU = 'VRU_EL';// Вводно-распределительное устройство ctsnGRSCH = 'GRSCH_EL'; // Главный распределительный щит ctsnAVR = 'AVR_EL'; // Аварийно-распределительное устройство ctsnUZO = 'UZO_EL'; // Устройство защитного отключения ctsnElCounter = 'EL_COUNTER'; // Счетчик электрический ctsnSwitchInput = 'EL_INPUTSHITCH'; // вводной автомат ctsnWireTray = 'WIRETRAY'; // Tolik 10/04/2025 -- Лоток проволочный // //*** ReportTypes rtResources = 1; rtCable = 2; rtCableCanal = 3; rtCableJournal = 5; rtCableJournalExt = 6; rtSpecification = 7; rtGOSTSpecification = 8; rtNorms = 9; rtExplanatoryReport = 10; rtLegendObjectIcons = 11; rtGOSTCableJournal = 12; rtPriorCostOfProject = 13; rtMarkRoomTS = 14; rtMarkPathPanel = 15; rtMarkPathPanelPorts = 16; rtMarkSocket = 17; rtMarkSocketPanel = 18; rtMarkCable = 19; rtExplicationRoom = 20; rtExplicationComponent = 21; rtGOSTCrossJournal = 22; rtCrossJournal = 23; rtDefectAct = 24; rtHouse = 25; rtCompoSpecification = 26; rtCommerceInvoice = 27; rtCablePaths = 28; rtCrossConnection = 29; //added by Tolik rtWACoordinates = 30; rtPortReport = 31; // Tolik 31/08/2023 -- // MarkTemplateElements mteProj = '#p'; mteList = '#l'; mteRoom = '#r'; mteObject = '#o'; mteTopCompon = '#C'; mteParentCompon = '#P'; mteCompon = '#c'; mteComponPort = '#t'; mteNameShort = '#s'; mtMinLength = 'minlen'; mtLetter = 'letter'; mtRadix = 'radix'; //*** CurrencyType ctSimple = 0; ctMain = 1; ctSecond = 2; const // Object_Icon_Type oitNone = 0; oitProjectible = 1; oitActive = 2; oitDefault = oitProjectible; oitAll = $FFFF; const // Icon ext ieBLK = 1; ieBMP = 2; // *** MemeTable Field Modify Type Const mtNone = 0; mtNew = 1; mtModify = 2; const // DataTypes dtNone = 0; dtFloat = 1; dtInteger = 2; dtBoolean = 3; dtString = 4; dtDate = 5; dtCompStateType = 6; // Тип обозначения (oitProjectible = 1; oitActive = 2) dtColor = 7; dtCableCanalElementType = 9; // Элемент каб канала dtDimensions = 10; dtBlob = 11; dtConnectionKind = 12; dtStringList = 13; // строковый список dtBasementType = 14; dtPlaneMaterialType = 15; // Тип материала для плоскости dtRoofHipType = 16; // Тип ребра крыши dtRoofHipApexType = 17; // Типы ребер-конька крыши dtRoofHipValleyType = 18; // Типы ребер-ендовы крыши dtLast = dtRoofHipValleyType; //InterbaseFieldTypes iftSmallInt = 7; iftInteger = 8; iftQuard = 9; iftFloat = 10; iftDFloat = 11; iftChar = 14; iftDouble = 27; iftDate = 35; iftVarChar = 37; iftBlob = 261; // ReadWrite Rights rwrRead = 01; rwrReadWrite = 02; rwrAdmin = 03; const // ResourceType //rtResource = 1; //rtTz = 2; //rtTzMash = 3; rtNone = 0; rtMat = 1; // Материал rtMachMech = 2; // Машинный механизм rtPrice = 3; // Прескурант //Time UOM tuMin = 1; tuHr = 2; const // GenderType gtFemale = 0; // мама gtMale = 1; // папа // RelType rtPortInterfRel = 1; rtInterfInternalConn = 2; const //SideType stNoneSide = 0; stSide1 = 1; stSide2 = 2; const // Component type ctNone = -1; ctConn = 0; ctLine = 1; ctArhRoom = 2; // Комната ctArhWall = 3; // Стена ctArhWallDivision = 4; // Перегородка ctArhFloor = 5; // Пол ctArhCeiling = 6; // Потолок ctArhEmbrasure = 7; // Проем ctArhWindow = 8; // Окно ctArhDoor = 9; // Проем ctArhNiche = 10; // Ниша ctArhInnerSlope = 11; // Откос ctArhOuterSlope = 12; // Откос внешний ctArhArc = 13; // Арка ctArhBalcony = 14; // Балкон ctArhBrickWall = 15; // Кирпичная стена ctArhWallCorner = 16; // Угол стены // используются для сохранения переметров объектов по умолчанию ctArhWndInnerSlope = 17; // Откос окна ctArhWndOuterSlope = 18; // Откос окна внешний ctArhDoorInnerSlope = 19; // Откос окна ctArhBalconyWnd = 20; // Окно балкона ctArhBalconyDoor = 21; // Дверь балкона ctArhBalconyInnerSlope = 22; // Внутренний откос балкона ctArhRoof = 23; // Крыша ctArhRoofSeg = 24; // Сегмент крыши ctArhRoofHip = 25; // Ребро крыши ctArhRoofHipCorner = 26; // Угол сегмента крыши const // ConnectType cntNone = 0; cntComplect = 1; cntUnion = 2; // Conect Rel Type - тип связи прямая/обратная crtDirect=1; crtReverse=2; const // ConnectorTypes contNone = 0; contAll = $FFFF; // любой тип contCork = 1; // заглушка contAnglePlane = 2; // Уголок Плоский contTjoin = 3; // Тройник contAngleIn = 4; // Уголок Внутренний contAngleOut = 5; // Уголок Внешний contAdapter = 6; // Адаптер contConnector = 7; // Соединитель contWallCork = 8; // Ввод в стену contCross = 9; // Крестовина //Tube connection kind tckNone = 00; tckFirst = 01; tckHubOfPipe = 01; //В раструб tckCapillarySoldering = 02; //Капиллярная пайка tckMechanicalCompressive = 03; //Механическое компрессионное tckMechanicalPress = 04; //Механическое прессовое tckMechanicalTread = 05; //Механическое резьбовое tckPress = 06; //Прессовое соединение tckWeldingConnection = 07; //Сварное tckWeldingButt = 08; //Сварное встык tckWeldHubOfPipe = 09; //Сварное в раструб tckWeldElectric = 10; //Электросварное tckLast = 10; // Plane material type //pmtNone = 0; //pmtSheeting = 1; // Листовой //pmtRoll = 2; // Рулонный //pmtTile = 3; // Черепица pmtNone = 0; pmtSheetSlate = 1; //'Листовое – шифер'; pmtSheetSteel = 2; //'Листовое - сталь листовая'; pmtRoller = 3; //'Рулонные'; pmtTileMetal = 4; //'Металочерепица'; pmtTileCeramic = 5; //'Черепица керамическая'; pmtTileBitumen = 6; //'Черепица битумная'; pmtTileInterlocking = 7; //'Черепица пазовая ленточная'; pmtOndura = 8; //'Ондура'; pmtOnduline = 9; //'Ондулин'; pmtFronton = 10; //'Фронтон'; pmtRoofBase = 11; //'Основание'; // Roof Hip Type - Типы ребер крыши rhtNone = 0; rhtApex = 1; // конек крыши rhtValley = 2; // ендова крыши rhtEaves = 3; // карнизный свес крыши rhtEnd = 4; // торец крыши rhtJunction = 5; // Примыкание крыши rhtRoofHip = 6; // Просто ребро // Roof Hip Apex Type - Типы ребер-конька крыши rhatNone = 0; rhatLargeRound = 1; // Конек круглый большой rhatSmallRound = 2; // Конек круглый малый rhatTrapezoidal = 3; // Конек трапецевидный rhatTriangularStraight = 4; // Конек треугольный прямой rhatStraight = 5; // Конек прямой // Roof Hip Valley Type - Типы ребер-ендовы крыши rhvtNone = 0; rhvtDeep = 1; //Ендова глубокая rhvtDecorative = 2; //Ендова декоративная rhvtLarge = 3; //Ендова большая // Basement types btStrip = 01; // Ленточный btColumnar = 02; // Столбчатый const // ConnectKinds flags cnkNone = $000; cnkFemaleMale = $001; // мама-папа cnkMaleFemale = $002; // папа-мама cnkFemaleFemale = $004; // мама-мама cnkMaleMale = $008; // папа-папа cnkSame = $010; // пол одинаковый cnkVarious = $020; // пол разный const // type_connect_object tcoFrom = 0; tcoTo = 1; const // Net Types ntComputer = 1; ntTelephone = 2; ntElectric = 3; ntTelevision = 4; ntGas = 5; // Come From Type cftUser = 1; cftAuto = 2; const // TInterfaceType itpNone = -1; itFunctional = 0; itConstructive = 1; const // TInterfaceKind ikNoSplit = 0; // Не разъемный ikSplit = 1; // Разъемный const //BoolInt biNone = -1; biFalse = 0; biTrue = 1; //BoolIntGrayed bigFalse = 0; bigTrue = 1; bigGray = -1; //BoolStr bsTrue = 'True'; bsFalse ='False'; bsGray = 'Gray'; //BoolStrShort bssTrue = '1'; bssFalse ='0'; bssGray = '-1'; // IsLineType ltIsLine = biTrue; ltIsPoint = biFalse; ltAnyType = 2; // TPortKind pkNone = -1; pkPort = 0; pkMultiport = 1; // Port State psPassive = 0; psActive = 1; const // TableKind ctkNone = -1; ctkComponent = 0; ctkCatalog = 1; ctkNorm = 2; ctkNBResources = 3; const // RefreshListType rltNone = 0; rltTracessStyle = 1; rltTracessFulness = 2; rltCADSignature = 4; // подписи rltNote = 8; // выноски // NB UpdateTableType uttSimple = 1; uttTree = 2; // NB UpdateRecordType urtNone = 0; urtInsert = 1; urtUpdate = 2; // Update info Relation Type rtDetail = 1; rtDirectory = 2; // Guid Length cnstGUIDLength = 40; cnstAbsUP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; cnstAbsCyrUP = 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦШЩЪЫЬЭЮЯ'; cnstCmpDelta = 0.0001; cnstCmpHeightDelta = cnstCmpDelta; cnstCmpLenDelta = cnstCmpDelta; cnstCmpPriceDelta = 0.001; cnstCmpNDSDelta = 0.01; cnstCmpMeasure = 0.01; cnstPropValMaxLen = 255; //SettingTypeIndex stiNone = -1; stiCommon = 0; stiNormBase = 1; stiReportDesigner = 2; stiColor = 4; stiEnvironmentOptions = 5; // Tolik -- 02/03/2017 -- stiImport = 6; stiExport = 7; // Tolik 11/07/2019 - - sti3D = 8; // Tolik 03/10/2019 stiElectrical = 9; // Tolik 02/03/2021 -- stiReserv = 10;// Tolik 28/12/2024 -- резервное копирование // // UseKindInProj: ukUsual = 1; ukSprav = 2; // Strig Types stUnitsOfMeasure = 1; //единицы измерения stDimensions = 2; // размеры // Guide file type gftCompSpecification = 1; // FilterTypes ftNone = 0; ftComponent = 1; ftConnectedLineCompons = 2; ftDisconnectedLineCompons = 3; ftConnectedConObjects = 4; ftDisconnectedConObjects = 5; ftConnDisconnCompons = 6; ftCablesNoInCanals = 7; ftCableSwerves = 8; ftNoConnectedRoutes = 9; // FilterFieldIndexes ffFunctionalInterface = 1; ffPort = 2; ffConnected = 3; ffNoConnected = 4; // Template group types tgtVirtualCompon = 1; // Tolik 21/02/2022 -- это будем понимать как компьютерную сеть tgtArh = 2; tgtRoof = 3; //Tolik 21/02/2022 -- tgtElectrical = 4; // электрика tgtFAS = 5; // пожарка - Fire Alarm Systems tgtCCTV = 6; // видеонаблюдение // // Currency Convertion Kinds cckByTarget = 1; // По валютам назначения - например по валютам проекта если из НБ в проект cckBySource = 2; // По валютам исходного места нахождения {$IF Not Defined(FINAL_SCS)} IsShowUnvisibleInterface = true; {$ELSE} IsShowUnvisibleInterface = false; {$IFEND} //IsShowUnvisibleInterface = IsShowUnvisibleInterfaceDef; const // Interfaces Names ID iidTwistedPair = 96; guidCTMufta = '{DA57B5EA-E45F-4092-A98C-B2F6EDECC063}'; guidTwistedPair = '{966A4B58-14A9-4B48-8C72-8616BDE5C1AE}'; guidTwistedPairFTP = '{E44AC07C-AA71-48B6-AB27-9E07CB297CEB}'; guidInterfCoaxial = '{D323D195-595A-4DF4-B669-B56D76EB7B61}'; guidInterf1pin = '{4546EF81-C089-4CEA-9F6F-2DB31DF34DF3}'; guidInterf2pin = '{38B1CDF8-9526-41BB-9571-35AA6D369C46}'; guidInterf3pin = '{44F2C083-EC54-48D6-A691-9707DE88A7A3}'; guidInterf4pin = '{56A9FB95-2D2A-4240-AB09-DE0C95A2D228}'; guidInterf6pin = '{B76ACA56-1916-4F47-86AA-C46AD9B0D9F2}'; guidInterf8pin = '{0624B9F9-6F2F-47A5-A75F-4986E490A4BA}'; guidInterf10pin = '{675FA203-DC5E-4BED-BB1B-41A99D88D4DD}'; guidInterf14pin = '{12731492-8F4B-40BB-9A98-9B8466190CAF}'; guidInterf16pin = '{EAD191D3-20F4-46ED-87B0-F8D656EFCFA3}'; guidRepTemplateSignature = 'E1DED013DAEB498B92F87340ECE3A284'; guidTableStreamSignature = 'B05203FFBE514835986BC31DD732A357'; guidProjMemTables = '3CA54D0AE9DA4843AF31EBBFADCD1B7D'; guidCompTypeResource = '{515467A1-D6EA-4284-9C9B-7CD88A13350E}'; guidCompTypeHouse = '{9D370529-D839-4E02-A698-134CA6DF3A48}'; guidCompTypeApproach = '{601B2ED9-520E-492F-A172-89A4E2B9881C}'; guidPropCooperative = '{65835654-64E4-4D74-9C61-2E8D6B80366F}'; guidPropHEO = '{E00574AD-66D4-4470-B898-1248FC3DFAC8}'; guidPropAgreed = '{3C38F6B9-5CF6-41F9-9E70-36548259A81C}'; guidPropBoxInstalled = '{C950EE83-7360-40F3-953A-5C77D37EF18F}'; guidPropPresencePower200WFromNetwork = '{C2CC2CB6-9C72-4394-8B16-E4E87FFA9C70}'; guidPropCableSetToBox1 = '{263E69F4-7885-4822-9A43-AA3FBA5AEB0C}'; guidPropCableSetToBox2 = '{049F56E0-E7B3-4FD4-AB44-03773102B6D6}'; guidPropCableSetToBox3 = '{B56D8AFD-4F6B-489A-B529-7ACEE29FEBDC}'; guidPropFiberOpticWelded = '{E70BB344-4902-4419-BF26-48127386DA63}'; guidPropEquipmentInstalled = '{CCC6DE9D-D509-4315-A13F-1D42735DA83A}'; guidPropDefect = '{746900E8-7EF2-4FBA-8C49-D7DA0CCF880D}'; guidCompTypeHousePropCooperative = '{76BBFFFC-D972-4946-A8EA-4A89F41CD22E}'; guidCompTypeHousePropHEO = '{93F5DF79-2F89-4A10-9689-FE1A1BBA3B7A}'; guidCompTypeHousePropAgreed = '{77737B81-AB59-409A-8E30-7D9C814EB2FD}'; guidCompTypeApproachPropBoxInstalled = '{789E2FEA-3B80-4217-96B0-5BA667C8CC09}'; guidCompTypeApproachPropPresencePower200WFromNetwork = '{1E49FD3B-5D8D-480E-B749-00E0E3A92AFE}'; guidCompTypeApproachPropCableSetToBox1 = '{F45DE6D5-23DE-4FA6-8AF4-3ECECA2919D1}'; guidCompTypeApproachPropCableSetToBox2 = '{F0A3A5A6-2027-4BE3-9EFB-30F2F392E4CD}'; guidCompTypeApproachPropCableSetToBox3 = '{2ED1C50C-8F02-4CCE-B675-A18EBBAF25D4}'; guidCompTypeApproachPropFiberOpticWelded = '{B289E235-453D-40E4-93DC-85DBA7E6104C}'; guidCompTypeApproachPropEquipmentInstalled = '{2203AC88-E15E-4370-A991-B9A38B60F87F}'; guidObjIconRoof = '{902ABA4E-CC12-45D6-8707-94704E2780F1}'; guidCatalogUserDir = '{27CD1215-3D47-404B-B82A-AA88634052E9}'; // Пользовательская база // Элементы каб. каналов, созданные автоматически guidCCECork = '{6E9C855F-EB15-443F-8DC4-F63C42D72FEA}'; // заглушка guidCCEAnglePlane = '{14AA5DE2-225F-4CA5-986B-0C531657C67A}'; // Уголок Плоский guidCCETjoin = '{53BBD325-4EDA-47D9-A87D-21AE3F2264E4}'; // Тройник guidCCEAngleIn = '{E0FEAEBE-2E1E-4448-A157-338FAACD15AA}'; // Уголок Внутренний guidCCEAngleOut = '{100F83FB-204A-496A-AEB9-39149191B344}'; // Уголок Внешний guidCCEAdapter = '{C3476431-ECB8-4404-9C62-9C4D8F415171}'; // Адаптер guidCCEConnector = '{11188169-4969-4B9D-A414-36B224FC91AC}'; // Соединитель guidCCEWallCork = '{5B1E910D-9C3D-49E9-9227-8C05814C792D}'; // Ввод в стену guidCCECross = '{92787069-C555-4B59-821F-79AC69F278BE}'; // Крестовина // Универсальные интерфейсы guidUniversalInterface = '{9D17BF04-78F0-4BD7-B02A-B6525A460A0C}'; // Универсальный интерфейс guidUniversalPort = '{EF9C7338-824A-4EAB-8C1B-49D0C9A54DF4}'; // Универсальный порт guidUniversalWire = '{9C807AD3-057F-4452-8D30-5F799F774E06}'; // Универсальная Жила guidUniversalOutConstr = '{8ABFB6A9-6656-4A84-8E59-57D930EFCD99}'; // Универсальный Внешний конструктив guidUniversalInConstr = '{736DA5D9-BEF0-4E31-AC51-41DA9F245E69}'; // Универсальный Внутренний конструктив guidUniversalChannelSide = '{8DB526EE-AD5A-4B36-B31B-1CCA0432C2F9}'; // Универсальная Сторона канала //*** FieldNames(Identificators) fiAll = 0; fiID = 1; fiIDComponent = 2; fiIDInterface = 3; fiTypeI = 4; fiKind = 5; fiIsPort = 6; fiIsUserPort = 7; fiNppPort = 8; fiIDConnected = 9; fiGender = 10; fnMultiple = 'MULTIPLE'; fiMultiple = 11; fnIsBusy = 'ISBUSY'; fiIsBusy = 12; fnValueI = 'VALUEI'; fiValueI = 13; fnCoordZ = 'COORDZ'; fiCoordZ = 14; fnSortID = 'SORT_ID'; fiSortID = 15; fnNumPair = 'NUM_PAIR'; fiNumPair = 16; fnColor = 'COLOR'; fiColor = 17; fnIDAdverse = 'ID_ADVERSE'; fiIDAdverse = 18; fnSide = 'SIDE'; fiSide = 19; fnName = 'NAME'; fiName = 30; fnNameShort = 'NAME_SHORT'; fiNameShort = 31; fnNameMark = 'NAME_MARK'; fiNameMark = 32; fnMarkID = 'MARK_ID'; fiMarkID = 33; fnIzm = 'IZM'; fiIzm = 34; fnIsUserMark = 'ISUSER_MARK'; fiIsUserMark = 35; fnPicture = 'PICTURE'; fiPicture = 36; fnIsLine = 'ISLINE'; fiIsLine = 37; fnIsComplect = 'ISCOMPLECT'; fiIsComplect = 38; fnPrice = 'PRICE'; fiPrice = 39; fnPriceCalc = 'PRICE_CALC'; fiPriceCalc = 40; fnUserLength = 'USER_LENGTH'; fiUserLength = 41; fnMaxLength = 'MAX_LENGTH'; fiMaxLength = 42; fnHasnds = 'HASNDS'; fiHasnds = 43; fnIDComponentType = 'ID_COMPONENT_TYPE'; fiIDComponentType = 44; fnIDCurrency = 'ID_CURRENCY'; fiIDCurrency = 45; fnArticulDistributor = 'ARTICUL_DISTRIBUTOR'; fiArticulDistributor = 46; fnArticulProducer = 'ARTICUL_PRODUCER'; fiArticulProducer = 47; fnIDProducer = 'ID_PRODUCER'; fiIDProducer = 48; fnIDSupplier = 'ID_SUPPLIER'; fiIDSupplier = 49; fnIDNetType = 'ID_NET_TYPE'; fiIDNetType = 50; fnWholeID = 'WHOLE_ID'; fiWholeID = 51; fnKolComplect = 'KOL_COMPLECT'; fiKolComplect = 52; fnIDNormbase = 'ID_NORMBASE'; fiIDNormbase = 53; fnObjectID = 'OBJECT_ID'; fiObjectID = 54; fnListID = 'LIST_ID'; fiListID = 55; fnProjectID = 'PROJECT_ID'; fiProjectID = 56; fiGuidComponentType = 57; fiGuidNetType = 58; fiGuidProducer = 59; //added by Tolik fnx = 'X'; fiX = 60; fnY = 'Y'; fiY = 61; fnZ = 'Z'; fiZ = 62; fnAccordComponIsLine = 'ACCORD_COMPON_ISLINE'; fnActiveBlk = 'ACTIVE_BLK'; fnActiveBmp = 'ACTIVE_BMP'; fnActiveState = 'ACTIVE_STATE'; fnActLimit = 'ACT_LIMIT'; fnActRowLimit = 'ACT_ROW_LIMIT'; fnAdditionalPrice = 'ADDITIONAL_PRICE'; fnAgreed = 'AGREED'; // согласовано fnAll = '*'; fnAngle = 'ANGLE'; fnApplyForAllSame = 'APPLY_FOR_ALL_SAME'; fnAppointmentRoom = 'APPOINTMENTROOM'; fnArticul = 'ARTICUL'; fnBackUpDate = 'BACKUP_DATE'; fnBaseline = 'BASELINE'; fnBeatenBlock = 'BEATEN_BLOCK'; fnBoxInstalled = 'BOX_INSTALLED'; // Ящик встановлено fnBuildID = 'BUILD_ID'; fnBusyDate = 'BUSY_DATE'; fnBusyTime = 'BUSY_TIME'; fnBusyType = 'BUSY_TYPE'; fnCableCanalConnectorsCnt = 'CABLE_CANAL_CONNECTORS_CNT'; fnCableCanalFullnessKoef = 'CABLE_CANAL_FULLNESS_KOEF'; fnCableCapacity = 'CABLE_CAPACITY'; fnCableData = 'CableData'; fnCableDiameter = 'CABLE_DIAMETER'; fnCableNameMark = 'CABLE_NAME_MARK'; fnCableNameShort = 'CABLE_NAME_SHORT'; fnCableNum = 'CABLE_NUM'; fnCableSetToBox = 'CABLE_SET_TO_BOX'; // Кабель заведено до ящика fnCADBlock = 'CAD_BLOCK'; fnCAD3D = 'CAD_3D'; fnCanUseAsPoint = 'CAN_USE_AS_POINT'; fnCaption = 'CAPTION'; fnCaseSensitive = 'CASE_SENSITIVE'; fnCategory = 'CATEGORY'; fnCharterLevel = 'CHARTERLEVEL'; fnChildColumns = 'CHILD_COLUMNS'; fnCode = 'CODE'; fnColumn = 'COLUMN'; fnColumnNum = 'COLUMN_NUM'; fnComeFrom = 'COME_FROM'; fnComment = 'COMMENT'; fnCompletePct = 'COMPLETE_PCT'; fnComponentType = 'COMPONENT_TYPE'; fnComponentTypes = 'COMPONENT_TYPES'; fnComponentIndex = 'COMPONENT_INDEX'; fnComponFilterBlock = 'COMPON_FILTER_BLOCK'; fnComponNameMark = 'COMPON_NAME_MARK'; fnComponNum = 'COMPONNUM'; fnComponObjectAddress = 'COMPON_OBJECT_ADDRESS'; fnComponTypeSysName = 'COMPON_TYPE_SYSNAME'; fnComponWholeID = 'COMPON_WHOLE_ID'; fnCompTypeMarkMasks = 'COMPTYPE_MARK_MASKS'; fnConnected = 'CONNECTED'; fnConnectingTraceID = 'CONNECTING_TRACE_ID'; fnConnectType = 'CONNECT_TYPE'; fnConnectorType = 'CONNECTOR_TYPE'; fnConnFromPos = 'CONN_FROM_POS'; fnConnToAnyGender = 'CONNTO_ANY_GENDER'; fnConnToPos = 'CONN_TO_POS'; fnContent = 'CONTENT'; fnConstructiveWidth = 'CONSTRUCTIVE_WIDTH'; fnContentKolvo = 'CONTENT_KOLVO'; fnCooperative = 'COOPERATIVE'; // кооператив fnCost = 'COST'; fnContractorName = 'CONTRACTOR_NAME'; // Подрядчик (исполнитель) fnCustomerName = 'CUSTOMER_NAME'; // Заказчик fnCount = 'COUNT'; fnCountForPoint = 'COUNT_FOR_POINT'; fnCurrencyMName = 'CURRENCY_M_NAME'; fnCurrencySName = 'CURRENCY_S_NAME'; fnCypher = 'CYPHER'; fnDateEntry = 'DATE_ENTRY'; fnDateExecution = 'DATE_EXECUTION'; fnDateGetting = 'DATE_GETTING'; fnDateIn = 'DATE_IN'; fnDataKind = 'DATA_KIND'; fnDateMod = 'DATE_MOD'; fnDefinedInterfNorms = 'DEFINED_INTERF_NORMS'; fnDefValue = 'DEF_VALUE'; fnDBName = 'DB_NAME'; fnDBType = 'DB_TYPE'; fnDefListSettings = 'DEF_LIST_SETTINGS'; fnDesc = 'DESC'; fnDescend = 'DESCEND'; fnDescription = 'DESCRIPTION'; fnDiameter = 'DIAMETER'; fnDiff = 'DIFF'; fnDone = 'DONE'; fnFieldList = 'FIELD_LIST'; fnFieldsToUpdate = 'FIELDS_TO_UPDATE'; fnFilterType = 'FILTER_TYPE'; fnFilterValue = 'FILTER_VALUE'; fnFirst1 = 'FIRST 1'; //fnFromDevice = 'From_Device'; //fnFromDeviceSecond = 'From_DeviceSecond'; //fnFromDeviceThird = 'From_DeviceThird'; //fnFromDeviceFourth = 'From_DeviceFourth'; fnDirItemType = 'DIR_ITEM_TYPE'; fnDisableEditing = 'DISABLE_EDITING'; fnEquipmentInstalled = 'EQUIPMENT_INSTALLED'; fnEndDate = 'END_DATE'; fnExceedLength = 'ExceedLength'; fnExpense = 'EXPENSE'; fnExpenseForLength = 'EXPENSE_FOR_LENGTH'; //fnExpenseForSection = 'EXPENSE_FOR_SECTION'; fnFiberOpticWelded = 'FIBER_OPTIC_WELDED'; // Оптика розварена fnFileExt = 'FILE_EXT'; fnFileName = 'FILE_NAME'; fnFilling = 'FILLING'; fnFindDefectChecked = 'FIND_DEFECT_CHECKED'; fnFindDefectAdress = 'FIND_DEFECT_ADRESS'; fnFindDefectDescription = 'FIND_DEFECT_DESCRIPTION'; fnFirstKolvo = 'FIRST_KOLVO'; fnFirstPrice = 'FIRST_PRICE'; fnFixed = 'FIXED'; fnFloor = 'FLOOR'; fnFromBuilding = 'From_Building'; fnFromDevice = 'From_Device'; fnFromDeviceSecond = 'From_DeviceSecond'; fnFromDeviceThird = 'From_DeviceThird'; fnFromDeviceFourth = 'From_DeviceFourth'; fnFromElement = 'From_Element'; fnFType = 'FTYPE'; fnGender = 'GENDER'; fnGeneratorName = 'GENERATOR_NAME'; fnGenerators = 'GENERATORS'; fnGuid = 'GUID'; fnGuidAccordance = 'GUID_ACCORDANCE'; fnGuidComponent = 'GUID_COMPONENT'; fnGuidComponentType = 'GUID_COMPONENT_TYPE'; fnGuidCrossProperty = 'GUID_CROSS_PROPERTY'; fnGuidCurrency = 'GUID_cURRENCY'; fnGUIDDesignIcon = 'GUIDDesignIcon'; fnGuidESmeta = 'GUID_ESMETA'; fnGuidInterface = 'GUID_INTERFACE'; fnGuidNB = 'GUID_NB'; fnGuidNBComponent = 'GUID_NBCOMPON'; fnGuidNBConnector = 'GUID_NB_CONNECTOR'; fnGuidNBNorm = 'GUID_NB_NORM'; fnGuidNBRES = 'GUID_NB_RES'; fnGuidNetType = 'GUID_NET_TYPE'; fnGuidObjectIcon = 'GUID_OBJECT_ICON'; fnGuidPort = 'GUID_PORT'; fnGuidProducer = 'GUID_PRODUCER'; fnGuidProperty = 'GUID_PROPERTY'; fnGuidPropValRel = 'GUID_PROP_VAL_REL'; fnGuidSuppliesKind = 'GUID_SUPPLIES_KIND'; fnGuidSupplier = 'GUID_SUPPLIER'; fnGuidSymbol = 'GUID_SYMBOL'; fnHeightCeiling = 'HEIGHT_CEILING'; fnHeightCorob = 'HEIGHT_COROB'; fnHeightRoom = 'HEIGHT_ROOM'; fnHeightSocket = 'HEIGHT_SOCKET'; fnHeightThroughFloor = 'HEIGHT_THROUGH_FLOOR'; fnHEO = 'HEO'; // ЖЭК housing and exploitation office fnIconType = 'ICON_TYPE'; fnID = 'ID'; //fnIDCableCanal = 'ID_CABLE_CANAL'; fnIDAccordance = 'ID_ACCORDANCE'; fnIDCADCrossObject = 'ID_CAD_CROSS_OBJECT'; fnIDCADNormStruct = 'ID_CAD_NORM_STRUCT'; fnIDCatalog = 'ID_CATALOG'; fnIDChild = 'ID_CHILD'; fnIDComponent = 'ID_COMPONENT'; fnIDComponFrom = 'ID_COMPON_FROM'; fnIDComponTemplate = 'ID_COMPON_TEMPLATE'; fnIDComponTo = 'ID_COMPON_TO'; fnIDComponWith = 'ID_COMPON_WITH'; fnIDCompPropRel = 'ID_COMP_PROP_REL'; fnIDCompRel = 'ID_COMP_REL'; fnIDCompRelFrom = 'ID_COMP_REL_FROM'; fnIDCompRelTo = 'ID_COMP_REL_TO'; fnIDCompRelWith = 'ID_COMP_REL_WITH'; fnIDCompSpecification = 'ID_COMP_SPECIFICATION'; fnIDConnectCompon = 'ID_CONNECT_COMPON'; fnIDConnected = 'ID_CONNECTED'; fnIDConnectObject = 'ID_CONNECT_OBJECT'; fnIDCrossConnection = 'ID_CROSS_CONNECTION'; fnIDCrossProperty = 'ID_CROSS_PROPERTY'; fnIDDataType = 'ID_DATA_TYPE'; fnIDDesignIcon = 'ID_DESIGN_ICON'; //fnIDDimension = 'ID_DIMENSION'; fnIDDirectoryType = 'ID_DIRECTORY_TYPE'; fnIDFile = 'ID_FILE'; fnIDFromOpened = 'ID_FROM_OPENED'; fnIDInterfRel = 'ID_INTERF_REL'; fnIDGroup = 'ID_GROUP'; fnIDInputString = 'ID_INPUT_STRING'; fnIDInterface = 'ID_INTERFACE'; fnIDInterfTo = 'ID_INTERF_TO'; fnIDIOfIRel = 'ID_IOFI_REL'; fnIDIOfIRelMain = 'ID_IOFI_REL_MAIN'; fnIDItemType = 'ID_ITEM_TYPE'; fnIDJoined = 'ID_JOINED'; fnIDLastList = 'ID_LAST_LIST'; fnIDList = 'ID_LIST'; fnIDNorm = 'ID_NORM'; fnIDMaster = 'ID_MASTER'; fnIDNB = 'ID_NB'; fnIDNBComponent = 'ID_NBCOMPON'; fnIDNBConnector = 'ID_NB_CONNECTOR'; fnIDNBNorm = 'ID_NB_NORM'; fnIDNBRES = 'ID_NB_RES'; fnIDNBResource = 'ID_NB_RESOURCE'; fnIDObjectIcon = 'ID_OBJECT_ICON'; fnIDOld = 'ID_OLD'; fnIDParentCompRel = 'ID_PARENTCOMPREL'; fnIDPropValRel = 'ID_PROP_VAL_REL'; fnIDPort = 'ID_PORT'; fnIDProperty = 'ID_PROPERTY'; fnIDRelatedCompon = 'ID_RELATEDCOMPON'; fnIDResource = 'ID_RESOURCE'; fnIDSideCompon = 'ID_SIDE_COMPON'; fnIDSuppliesKind = 'ID_SUPPLIES_KIND'; fnIDSymbol = 'ID_SYMBOL'; fnIDTopCompon = 'ID_TOP_COMPON'; fnIDUpdateInfo = 'ID_UPDATE_INFO'; //fnIDUnitOfMeasure = 'ID_UNIT_OF_MEASURE'; fnIndexConn = 'INDEX_CONN'; fnIndexJoiner = 'INDEX_JOINER';//'INDEX_LINE'; fnIndexLine = 'INDEX_LINE'; //'INDEX_JOINER'; fnInPointX = 'IN_POINT_X'; fnInPointY = 'IN_POINT_Y'; fnInterf = 'INTERF'; fnInterfaceIsBusy = 'INTERFACE_ISBUSY'; fnInterfComponIsLine = 'INTERF_COMPON_ISLINE'; fnInterfCount = 'INTERF_COUNT'; fnInterfAccordanceCount = 'INTERF_ACCORDANCE_COUNT'; fnInterfNormsCount = 'INTERF_NORMS_COUNT'; fnInterfRelNames = 'INTERF_REL_NAMES'; fnIOfIRelCount = 'IOFI_REL_COUNT'; fnIsAutoSaveProjects = 'IS_AUTO_SAVE_PROJECTS'; fnIsCharter = 'ISCHARTER'; fnIsComponConn = 'ISCOMPONCONN'; fnIsComponLine = 'ISCOMPONLINE'; fnIsCountry = 'ISCOUNTRY'; fnIsCrossControl = 'ISCROSS_CONTROL'; fnIsDefault = 'ISDEFAULT'; fnIsDirectory = 'ISDIRECTORY'; fnIsDismount = 'ISDISMOUNT'; fnIsFolder = 'ISFOLDER'; fnIsForWholeComponent = 'IS_FOR_WHOLE_COMPONENT'; fnIsFromInterface = 'ISFROM_INTERFACE'; fnIsIndexWithName = 'ISINDEX_WITH_NAME'; fnIsList = 'ISLIST'; fnIsMarkInCaptions = 'ISMARK_IN_CAPTIONS'; fnIsModified = 'ISMODIFIED'; fnIsNative = 'ISNATIVE'; fnIsNew = 'ISNEW'; fnIsOn = 'ISON'; fnIsPriceForSuppliesKind = 'IS_PRICE_FOR_SUPPLIES_KIND'; fnIsPort = 'ISPORT'; fnIsResource = 'ISRESOURCE'; fnIsRoom = 'ISROOM'; fnIsSCSline = 'ISSCSLINE'; fnIsSCSConnector = 'ISSCSCONNECTOR'; fnisStandart = 'ISSTANDART'; fnIsProject = 'ISPROJECT'; fnIsTakeJoinForPoints = 'ISTAKE_JOIN_FOR_POINTS'; fnIsTemplate = 'ISTEMPLATE'; fnIsTotal = 'ISTOTAL'; fnIsUniversal = 'ISUNIVERSAL'; fnIsUseDismounted = 'ISUSEDISMOUNTED'; fnIsUserName = 'ISUSER_NAME'; fnIsUserPort = 'ISUSER_PORT'; fnIsValueRelToObj = 'ISVALUE_REL_TO_OBJ'; fnIsVisible = 'ISVISIBLE'; fnItemsCount = 'ITEMS_COUNT'; fnIzmTradUOM = 'IZM_TRADUOM'; fnJoinsCount = 'JOINS_COUNT'; fnKind = 'KIND'; fnKoefLengthForCompl = 'KOEF_LENGTH_FOR_COMPL'; fnKolCompon = 'KOL_COMPON'; fnKolSubComplect = 'KOL_SUB_COMPLECT'; fnKolvo = 'KOLVO'; fnKolvoBusy = 'KOLVO_BUSY'; fnLaborTime = 'LABOR_TIME'; fnLastID = 'LASTID'; fnLastUserID = 'LASTUSERID'; fnLength = 'LENGTH'; fnLengthKoef = 'LENGTH_KOEF'; fnLengthReserv = 'LENGTH_RESERV'; fnLinkTransportChecked = 'LINK_TRANSPORT_CHECKED'; fnLinkTransportPointA = 'LINK_TRANSPORT_POINTA'; fnLinkTransportPointB = 'LINK_TRANSPORT_POINTB'; fnLinkTransportCable = 'LINK_TRANSPORT_CABLE'; fnLinkTransportMaterials = 'LINK_TRANSPORT_MATERIALS'; fnMain = 'MAIN'; fnMargin = 'MARGIN'; fnMarkMask = 'MARK_MASK'; fnMarkStr = 'MARK_STR'; fnMaterialCost = 'MATERIAL_COST'; fnMax = 'MAX'; fnMaxValue = 'MAX_VALUE'; fnMinValue = 'MIN_VALUE'; fnModel = 'MODEL'; fnMoveEquipmentChecked = 'MOVE_EQUIPMENT_CHECKED'; fnMoveEquipmentPointA = 'MOVE_EQUIPMENT_POINTA'; fnMoveEquipmentPointB = 'MOVE_EQUIPMENT_POINTB'; fnMoveEquipmentEqipm = 'MOVE_EQUIPMENT_EQIPM'; fnMoveEquipmentMaterial = 'MOVE_EQUIPMENT_MATERIAL'; fnMultiportReserv = 'MULTIPORT_RESERV'; fnNameAccordance = 'NAME_ACCORDANCE'; fnNameCable = 'Name_Cable'; fnNameBegin = 'NAME_BEGIN'; fnNameBeginCompon = 'NAME_BEGIN_COMPON'; fnNameBeginFull = 'NAME_BEGIN_FULL'; fnNameBrief = 'NAME_BRIEF'; fnNameConnectCable = 'NAME_CONNECT_CABLE'; fnNameEnd = 'NAME_END'; fnNameEndCompon = 'NAME_END_COMPON'; fnNameEndFull = 'NAME_END_FULL'; fnNameFrom = 'NAME_FROM'; fnNameList = 'NAME_LIST'; fnNameNetType = 'NAME_NET_TYPE'; fnNamePlural = 'NAME_PLURAL'; fnNameSimple = 'NAME_SIMPLE'; fnNameTo = 'NAME_TO'; fnNameTradUOM = 'NAME_TRADUOM'; fnNameWith = 'NAME_WITH'; fnNat = 'NAT'; fnNBBuildID = 'NB_BUILD_ID'; fnNDS = 'NDS'; fnNoConnected = 'NOCONNECTED'; fnNormCost = 'NORM_COST'; fnNormObjectAddress = 'NORM_OBJECT_ADDRESS'; fnNormsCount = 'NORMS_COUNT'; fnNote = 'Note'; fnNotice = 'NOTICE'; fnNpp = 'NPP'; fnNppFrom = 'NPP_FROM'; fnNppPort = 'NPP_PORT'; fnNppTo = 'NPP_TO'; fnNppWith = 'NPP_WITH'; fnNumCable = 'NumCable'; fnNumFrom = 'NUM_FROM'; fnNumTo = 'NUM_TO'; fnNumPairsStr = 'NUM_PAIRS_STR'; fnObjectData = 'OBJECT_DATA'; fnObjectAddress = 'OBJECT_ADDRESS'; fnObjectIcon = 'OBJECT_ICON'; fnObjectIconDesign = 'OBJECT_ICON_DESIGN'; fnObjectIconStep = 'OBJECT_ICON_STEP'; fnObjIDs = 'OBJ_IDS'; fnObjGUID = 'OBJ_GUID'; fnObjType = 'OBJ_TYPE'; fnParamField = 'PARAM_FIELD'; fnParams = 'PARAMS'; fnParentID = 'PARENT_ID'; fnPass = 'PASS'; fnPassStatus = 'PASSSTATUS'; fnPathType = 'PATH_TYPE'; fnPMBlock = 'PM_BLOCK'; fnPortInterfRelCount = 'PORT_INTERF_REL_COUNT'; fnPortKind = 'PORT_KIND'; //fnPortLastKolvo = 'PORT_LAST_KOLVO'; fnPortNameFrom = 'PORT_NAME_FROM'; fnPortNameTo = 'PORT_NAME_TO'; fnPortReserv = 'PORT_RESERV'; fnPortTypeFrom = 'PORT_TYPE_FROM'; fnPortTypeTo = 'PORT_TYPE_TO'; fnPosConnectionsCount = 'POS_CONNECTIONS_COUNT'; fnPosType = 'POS_TYPE'; fnPresencePower200WFromNetwork = 'PRESENCE_POWER_200W_FROM_NETWORK'; // Наявність живлення від мережі 200 В fnPriceNB = 'PRICE_NB'; fnPricePerTime = 'PRICE_PER_TIME'; fnPriceSupply = 'PRICE_SUPPLY'; fnProducerName = 'PRODUCER_NAME'; fnProjBlk = 'PROJ_BLK'; fnProjBmp = 'PROJ_BMP'; fnProjectAutoSaveMinutes = 'PROJECT_AUTO_SAVE_MINUTES'; fnPropsCount = 'PROPS_COUNT'; fnPropValRelCount = 'PROP_VAL_REL_COUNT'; fnPropValNormResCount = 'PROP_VAL_NORM_RES_COUNT'; fnPValue = 'PVALUE'; fnPValueSrc = 'PVALUE_SRC'; fnQt = 'QT'; fnRatio = 'RATIO'; fnRelationType = 'RELATION_TYPE'; fnRelFieldName = 'REL_FIELD_NAME'; fnRelTableName = 'REL_TABLE_NAME'; fnRelType = 'REL_TYPE'; fnRepBlob = 'REP_BLOB'; fnRepKind = 'REP_KIND'; fnReservBlk = 'RESERV_BLK'; fnReservBmp = 'RESERV_BMP'; fnResourcesCount = 'RESOURCES_COUNT'; fnRightsNB = 'RIGHTSNB'; fnRightsPM = 'RIGHTSPM'; //Made by Tolik for ExplicationComponentReport( by Cabinet) fnRoomName = 'ROOMNAME'; fnRoomNum = 'ROOMNUM'; //Made by Tolik for ExplanatoryList fnMaterialsCost = 'MATERIALS_COST'; fnResourcesCost = 'RESOURCESCOST'; fnWorksCost = 'WORKSCOST'; //Made by Tolik for CableJournal report fnMarks = 'MARKS'; fnPrices = 'PRICES'; fnReelName = 'REELNAME'; // наименование катушки, из которой отрезан кабель fnRType = 'RTYPE'; fnRValue = 'RVALUE'; fnSavedMain = 'SAVED_MAIN'; fnScript = 'SCRIPT'; fnSCSID = 'SCS_ID'; fnSection = 'SECTION'; fnSelfFromPos = 'SELF_FROM_POS'; fnSelfToPos = 'SELF_TO_POS'; fnSeparator = 'SEPARATOR'; fnSetEquipmentChecked = 'SET_EQUIPMENT_CHECKED'; fnSetEquipmentAddress = 'SET_EQUIPMENT_ADDRESS'; fnSetEquipmentEqipm = 'SET_EQUIPMENT_EQIPM'; fnSetEquipmentMaterial = 'SET_EQUIPMENT_MATERIAL'; fnSettings = 'SETTINGS'; fnSideSection = 'SIDE_SECTION'; fnSign = 'Sign'; fnSignType = 'SIGN_TYPE'; //fnSpravComponCount = 'SPRAV_COMPON_COUNT'; fnSquareInside = 'SQUAREINSIDE'; //fnStepCountForPoint = 'STEP_COUNTFORPOINT'; fnStartDate = 'START_DATE'; fnStepOfPoint = 'STEPOFPOINT'; fnStrType = 'STR_TYPE'; fnSuppliesKindName = 'SUPPLIES_KIND_NAME'; fnSuppliesKindUnitKolvo = 'SUPPLIES_KIND_UNIT_KOLVO'; fnSysName = 'SYSNAME'; fnTableKind = 'TABLE_KIND'; fnTableKindNB = 'TABLE_KIND_NB'; fnTableName = 'TABLE_NAME'; fnTableType = 'TABLE_TYPE'; fnTakeIntoConnect = 'TAKE_INTO_CONNECT'; fnTakeIntoJoin = 'TAKE_INTO_JOIN'; fnTemplateType = 'TEMPLATE_TYPE'; fnTimeIn = 'TIME_IN'; fnTimeUOM = 'TIME_UOM'; fnTmpAnswerCode = 'TMPCA'; fnTmpMACAddress = 'TMPAM'; fnTmpMaxConnCount = 'TMPCCM'; fnTmpPathCheckSum = 'TMPSCP'; fnToBuilding = 'To_Building'; fnToDevice = 'To_Device'; fnToDeviceSecond = 'To_DeviceSecond'; fnToDeviceThird = 'To_DeviceThird'; fnToDeviceFourth = 'To_DeviceFourth'; fnToElement = 'To_Element'; fnTotalLaborTime = 'TOTAL_LABOR_TIME'; //fnTotalLaborTimeOld = 'TOTAL_LABOR_TIME_OLD'; fnTraceCabling = 'TraceCabling'; fnTotalCost = 'TOTAL_COST'; fnTotalKolvo = 'TOTAL_KOLVO'; fnTransToUOM = 'TRANS_TO_UOM'; fnTypeConnect = 'TYPE_CONNECT'; fnTypeI = 'TYPEI'; fnTypeS = 'TYPES'; fnTType = 'TTYPE'; fnTwistedPairMaxLength = 'TWISTED_PAIR_MAX_LENGTH'; fnUOM = 'UOM'; //UnitOfMeasure fnUpdateAllData = 'UPDATE_ALL_DATA'; //fnUpdateDate = 'UPDATE_DATE'; //fnUpdateTime = 'UPDATE_TIME'; fnUpdateType = 'UPDATE_TYPE'; fnUnitInterfKolvo = 'UNIT_INTERF_KOLVO'; fnUnitKolvo = 'UNIT_KOLVO'; fnUnitKolvoTradUOM = 'UNIT_KOLVO_TRADUOM'; fnUseAsShablon = 'USE_AS_SHABLON'; fnUseInCad = 'USE_IN_CAD'; fnUseKindInProj = 'USE_KIND_IN_PROJ'; fnUseCount = 'USE_COUNT'; fnUserDate = 'USER_DATE'; fnUserName = 'USER_NAME'; fnUserTime = 'USER_TIME'; fnUsr = 'USR'; fnUsrList = 'USRLIST'; fnValue = 'VALUE'; fnValueReq = 'VALUE_REQ'; fnWorkersAmount = 'WORKERS_AMOUNT'; fnWorkKind = 'WORK_KIND'; //*** Generator Indexes giKatalogID = 00; giKatalogSCSID = 01; giCatalogRelationID = 02; giComponentID = 03; giComponentWholeID = 04; giCatalogMarkMaskID = 05; giCatalogPropRelationID = 06; giComponentRelationID = 07; giCompPropRelationID = 08; giCableCanalConnectorsID = 09; giConnectedComponentsID = 10; giInterfaceRelationID = 11; giInterfOfInterfRelationID = 12; giPortInterfaceRelationID = 13; giNormsID = 14; giNormResourceRelID = 15; giResourcesID = 16; giCADNormStructID = 17; giCADNormColumnID = 18; giInterfPosConnectionID = 19; giCADCrossObjectID = 20; giCADCrossObjectElementID = 21; giStringID = 22; giFilterinfoID = 23; giObjectsBlobID = 24; //*** Generator names gnCableCanalConnectorsID = 'GEN_CABLE_CANAL_CONNECTORS_ID'; gnCatalogPropRelationID = 'GEN_CATALOG_PROP_RELATION_ID'; gnComponentCypher = 'GEN_COMPONENT_CYPHER'; gnComponentID = 'GEN_COMPONENT_ID'; gnComponentRelationID = 'GEN_COMPONENT_RELATION_ID'; gnComponentTypesID = 'GEN_COMPONENT_TYPES_ID'; gnCompPropRelationID = 'GEN_COMP_PROP_RELATION_ID'; gnCompTypePropRelationID = 'GEN_COMP_TYPE_PROP_RELATION_ID'; gnCrossConnectionID = 'GEN_CROSS_CONNECTION_ID'; gnDirectoryTypeID = 'GEN_DIRECTORY_TYPE_ID'; gnDirectoryTypeRelID = 'GEN_DIRECTORY_TYPE_REL_ID'; gnFilesID = 'GEN_FILES_ID'; gnInputStringsID = 'GEN_INPUT_STRINGS_ID'; gnInterfaceID = 'GEN_INTERFACE_ID'; gnInterfaceAccordanceID = 'GEN_INTERFACE_ACCORDANCE_ID'; gnInterfaceNormsID = 'GEN_INTERFACE_NORMS_ID'; gnInterfaceRelationID = 'GEN_INTERFACE_RELATION_ID'; gnInterfOfInterfRelationID = 'GEN_INTERFOFINTERF_RELATION_ID'; gnKatalogID = 'GEN_KATALOG_ID'; gnNBNormsID = 'GEN_NB_NORMS_ID'; gnNBResourcesID = 'GEN_NB_RESOURCES_ID'; gnNetTypeID = 'GEN_NET_TYPE_ID'; gnNormResourceRelID = 'GEN_NORM_RESOURCE_REL_ID'; gnGenNormsID = 'GEN_NORMS_ID'; gnObjectCurrencyRelID = 'GEN_OBJECT_CURRENCY_REL_ID'; gnObjectIconsID = 'GEN_OBJECT_ICONS_ID'; gnPortInterfaceRelationID = 'GEN_PORT_INTERFACE_RELATION_ID'; gnProducersID = 'GEN_PRODUCERS_ID'; gnProjectRevID = 'GEN_PROJECT_REV_ID'; gnPropertiesID = 'GEN_PROPERTIES_ID'; gnPropValRelID = 'GEN_PROP_VAL_REL_ID'; gnPropValNormResID = 'GEN_PROP_VAL_NORM_RES_ID'; gnReportSortInfoID = 'GEN_REPORT_SORT_INFO_ID'; gnResourcesID = 'GEN_RESOURCES_ID'; gnSuppliesAccordanceID = 'GEN_SUPPLIES_ACCORDANCE_ID'; gnSuppliesKindsID = 'GEN_SUPPLIES_KINDS_ID'; gnTemplateGroupsID = 'GEN_TEMPLATE_GROUPS_ID'; gnTemplateRelationID = 'GEN_TEMPLATE_RELATION_ID'; gnUserReportsID = 'GEN_USER_REPORTS_ID'; // Help Indexes hiNormBase = 53000; hiNormBaseToolsPanel = 55000; hiNormBaseTreeElements = 54000; hiNormBaseObjectElemens = 60000; hiProjMan = 62000; hiProjManToolsPanel = 65000; hiProjManTreeElements = 64000; hiProjManObjectElemens = 66001; //PropIDs piAutotracing = 44; //PropsNames pnAllowEaves = 'ALLOW_EAVES'; pnAngle = 'ANGLE'; // угол pnAutotracing = 'AUTOTRACING'; pnBottomBound = 'BOTTOM_BOUND'; pnCableCanalElemetType = 'CABLE_CANAL_ELEMET_TYPE'; pnCableChannelFullnessKoef = 'CABLE_CHANNEL_FULLNESS_KOEF'; //Коэффициент заполненности кабельных каналов pnCableChannelSideSection = 'CABLE_CHANNEL_SIDE_SECTION'; // Сечение стороны кабельного канала pnConduitSideDimensions = 'CONDUIT_SIDE_DIMENSIONS'; // Размеры сторон кабельного канала pnConduitElmentSideDimensions = 'CONDUITELMT_SIDE_DIMNS'; // Размеры стороны элемента канала pnConduitElmentSide1Dimensions = 'CONDUITELMT_SIDE1_DIMNS'; // Размеры стороны 1 элемента канала pnConduitElmentSide2Dimensions = 'CONDUITELMT_SIDE2_DIMNS'; // Размеры стороны 2 элемента канала pnConduitElmentSide3Dimensions = 'CONDUITELMT_SIDE3_DIMNS'; // Размеры стороны 3 элемента канала pnConduitElmentSide4Dimensions = 'CONDUITELMT_SIDE4_DIMNS'; // Размеры стороны 4 элемента канала pnCategory = 'CATEGORY'; pnColor = 'COLOR'; pnComponentFrom = 'COMPONENT_FROM'; pnCoordZ = 'COORDZ'; //pnBearingWall = 'BEARING_WALL'; pnBasement = 'BASEMENT'; pnDefect = 'DEFECT'; pnDepth = 'DEPTH'; // Глубина pnDesignUnitPos = 'DESIGN_UNIT_POS'; // Позиция юнита для дизайна pnExpenseForMetr = 'EXPENSE_FOR_METR'; pnExpenseForSection = 'EXPENSE_FOR_SECTION'; pnGroupName = 'GROUP_NAME'; pnHeight = 'HEIGHT'; pnHeightInUnits = 'HEIGHT_IN_UNITS'; pnHeightRoom = 'HEIGHT_ROOM'; pnHeightCeiling = 'HEIGHT_CEILING'; pnHeightSocket = 'HEIGHT_SOCKET'; pnHeightCorob = 'HEIGHT_COROB'; pnHeightOfPlacing = 'HEIGHT_OF_PLACING'; // Высота размещения pnHeightSide1 = 'HEIGHT_SIDE1'; pnHeightSide2 = 'HEIGHT_SIDE2'; pnHeightWalls = 'HEIGHT_WALLS'; pnInDiametr = 'IN DIAMETR'; pnInSection = 'IN_SECTION'; pnMaxComplectCount = 'MAX_COMPLECT_COUNT'; pnOutDiametr = 'OUT DIAMETR'; pnOutSection = 'OUT_SECTION'; pnPercentCableLengthReserv = 'PERCENT_CABLE_LENGTH_RESERV'; //Процент запаса длины кабеля pnPerimeter = 'PERIMETER'; // Периметр pnPerimeterCeil = 'PERIMETER_CEIL'; // Периметр потолка pnPerimeterFloor = 'PERIMETER_FLOOR'; // Периметр пола pnPerimeterFloorFull = 'PERIMETER_FLOOR_FULL'; // Полный периметр пола pnPerimeterOut = 'PERIMETER_OUT'; // Периметр снаружи pnPerimeterSlope = 'PERIMETER_SLOPE'; // Периметр откосов pnPortCount = 'PORTCOUNT'; pnPortWireCount = 'PORT_WIRE_COUNT'; pnReservAtPointCompon = 'RESERV_AT_POINT_COMPON'; pnReservThroughPointCompon = 'RESERV_THROUGH_POINT_COMPON'; pnResidue = 'RESIDUE'; // использовать для вычета - или проем pnSectionSize = 'SECTION_SIZE'; pnThickness = 'THICKNESS'; pnTwistedPairMaxLength = 'TWISTED_PAIR_MAX_LENGTH'; //Ограничение по макс. длине (только для компонент с интерфейсами "Витая пара") pnTubeJoinKind = 'TUBE_JOIN_KIND'; pnWireCount = 'WIRE_COUNT'; pnLeftBound = 'LEFT_BOUND'; pnLength = 'LENGTH'; pnLengthProj = 'LENGTH_PROJ'; pnLengthKoef = 'LENGTH_KOEF'; pnMultimode = 'MULTIMODE'; pnMultiPortReserv = 'MULTIPORT_RESERV'; pnPortReserv = 'PORT_RESERV'; pnRightBound = 'RIGHT_BOUND'; pnShield = 'SHIELD'; pnSignType = 'SIGN_TYPE'; pnSlotWidth = 'SLOT_WIDTH'; pnSquare = 'SQUARE'; pnSquareOut = 'SQUARE_OUT'; // Площадь снаружи pnSquareCeil = 'SQUARE_CEIL'; // Площадь потолка pnSquareFloor = 'SQUARE_FLOOR'; // Площадь пола pnSquareEmbrasureLess = 'SQUARE_EMBRASURE_LESS'; // Площадь без проемов pnSquareExceptEmbrasureSlopeLess = 'SQUARE_EXCEPT_EMBRASURE_SLOPE_LESS'; // Площадь за исключением проемов без откосов pnSquareInclEmbrasureSlope = 'SQUARE_INCL_EMBRASURE_SLOPE'; // Площадь с учетом проемов и откосов pnSquareSlope = 'SQUARE_SLOPE'; // Площадь откосов pnSquarePlasterboardPerimetr = 'SQUARE_PLASTERBOARD_PERIMETR'; // Площадь периметра гипсокартона pnTopBound = 'TOP_BOUND'; pnTraceCabinig = 'TRACE_CABINING'; //pnWallDivSquareExceptEmbrasureSlopeLess = 'WALLDIV_SQUARE_EXCEPT_EMBRASURE_SLOPE_LESS'; //27.04.2012 - Площадь стен перегородки за вычетом проемов (без откосов) pnWallSquare = 'WALL_SQUARE'; // Площадь стены pnWallsSquare = 'WALLS_SQUARE'; // Площадь стен pnWallSquareEmbrasureLess = 'WALL_SQUARE_EMBRASURE_LESS'; // Площадь стен без проемов pnWallSquareExceptEmbrasureSlopeLess = 'WALL_SQUARE_EXCEPT_EMBRASURE_SLOPE_LESS'; // Площадь стен за исключением проемов без откосов pnWallSquareInclEmbrasureSlope = 'WALL_SQUARE_INCL_EMBRASURE_SLOPE'; // Площадь стен с учетом проемов и откосов pnWidth = 'WIDTH'; pnWidthOut = 'WIDTH_OUT'; // Ширина снаружи pnCooperative = 'COOPERATIVE'; // кооператив pnHEO = 'HEO'; // ЖЭК housing and exploitation office pnAgreed = 'AGREED'; // согласовано pnBoxInstalled = 'BOX_INSTALLED'; // Ящик встановлено pnPresencePower200WFromNetwork = 'PRESENCE_POWER_200W_FROM_NETWORK'; // Наявність живлення від мережі 200 В pnCableSetToBox = 'CABLE_SET_TO_BOX'; // Кабель заведено до ящика pnFiberOpticWelded = 'FIBER_OPTIC_WELDED'; // Оптика розварена pnEquipmentInstalled = 'EQUIPMENT_INSTALLED'; // Обладнання встановлено pnPlinthHeight = 'PLINTH_HEIGHT'; //pnPlinthHeightFromGround = 'PLINTH_HEIGHT_FROM_GROUND'; // Высота цоколя от земли //04.10.2010 pnBasementDepth = 'BASEMENT_DEPTH'; //pnBasementDepthToGround = 'BASEMENT_DEPTH_TO_GROUND'; // Глубина фундамента относительно земли//04.10.2010 pnBasementTotalHeight = 'BASEMENT_TOTAL_HEIGHT'; // Общ. высота фундамента //04.10.2010 pnPlinthVolume = 'PLINTH_VOLUME'; // Объем цоколя //pnBasementVolumeAboveGround = 'BASEMENT_VOLUME_ABOVE_GROUND'; // Объем фундамента над землей pnPlinthSidesSquare = 'PLINTH_SIDES_SQUARE'; // Площадь боковых граней цоколя (внешн + внутрун) pnPlinthSurfaceSquare = 'PLINTH_SURFACE_SQUARE'; // Площадь поверхности цоколя //pnBasementVolumeunderGround = 'BASEMENT_VOLUME_UNDER_GROUND'; // Объем фундамента под землей pnBasementArea = 'BASEMENT_AREA'; pnBasementVolume = 'BASEMENT_VOLUME'; // Объем фундамента pnPlinthThickness = 'PLINTH_THICKNESS'; // Толщина цоколя //pnBasementThicknessAboveGround = 'BASEMENT_THICKNESS_ABOVE_GROUND'; // Толщина фундамента над землей pnBasementThickness='BASEMENT_THICKNESS'; //толщина фундамента //pnBasementThicknessUnderGround = 'BASEMENT_THICKNESS_UNDER_GROUND'; // Толщина фундамента под землей pnTrenchVolume = 'TRENCH_VOLUME'; // Объем траншеи pnTrenchDepth = 'TRENCH_DEPTH'; // Глубина траншеи pnWallsOutSquare = 'WALLS_OUT_SQUARE'; //Площадь стен снаружи pnBasementColumnCount = 'BASEMENT_COLUMN_COUNT'; //Количество столбов между углами pnBasementColumnH = 'BASEMENT_COLUMN_H'; //Высота столбов pnBasementColumnW = 'BASEMENT_COLUMN_W'; //Ширина столбов pnBasementColumnL = 'BASEMENT_COLUMN_L'; //Длина столбов pnBasementColumnV = 'BASEMENT_COLUMN_V'; //Объем столбов pnBasementColumnVBetwCorner = 'BASEMENT_COLUMN_V_BETW_CORNER'; //Объем столбов между углами pnWallsVolume = 'WALLS_VOLUME'; // Объем стен pnVolume = 'VOLUME'; // Объем pnMaterialType = 'MATERIAL_TYPE'; // Тип материала pnRoofHipType = 'ROOF_HIP_TYPE'; // Тип ребра крыши pnRoofHipApexType = 'ROOF_HIP_APEX_TYPE'; // Типы ребер-конька крыши pnRoofHipValleyType = 'ROOF_HIP_VALLEY_TYPE'; // Типы ребер-ендовы крыши pnMaterialHeight = 'MATERIAL_HEIGHT'; // Высота материала pnMaterialHeightUsable = 'MATERIAL_HEIGHT_USABLE'; // Высота материала полезная pnMaterialWidth = 'MATERIAL_WIDTH'; // Ширина материала pnMaterialWidthUsable = 'MATERIAL_WIDTH_USABLE'; // Ширина материала полезная pnConsiderRemains = 'CONSIDER_REMAINS'; // Учитывать остатки pnAreaWithRemains = 'AREA_WITH_REMAINS'; // Площать с остатками pnContiguityFromPerimetr = 'CONTIGUITY_FROM_PERIMETR'; // Примыкания - из периметра проемов pnCuttingWithRemains = 'CUTTING_WITH_REMAINS'; // Крой с учетом отходов pnDescentSize = 'DESCENT_SIZE'; // Размер спуска = 0.05м pnVentSideSize = 'VENT_SIDE_SIZE'; // Размер бокового напуска = 0.07м pnRemainsMinUseSize = 'REMAINS_MIN_USE_SIZE'; //Мин. размер остатков для использования pnPerimeterEmbrasures = 'PERIMETER_EMBRASURES'; // Периметр проемов pnTypeSize1 = 'TYPE_SIZE_1'; // Типоразмер 1 pnTypeSize2 = 'TYPE_SIZE_2'; // Типоразмер 2 pnTypeSize3 = 'TYPE_SIZE_3'; // Типоразмер 3 pnTypeSize4 = 'TYPE_SIZE_4'; // Типоразмер 4 pnTypeSize1RowCount = 'TYPE_SIZE_1_ROW_COUNT'; // Кол-во рядов типоразмера 1 pnTypeSize2RowCount = 'TYPE_SIZE_2_ROW_COUNT'; // Кол-во рядов типоразмера 2 pnTypeSize3RowCount = 'TYPE_SIZE_3_ROW_COUNT'; // Кол-во рядов типоразмера 3 pnTypeSize4RowCount = 'TYPE_SIZE_4_ROW_COUNT'; // Кол-во рядов типоразмера 4 pnTypeSize1ElCount = 'TYPE_SIZE_1_EL_COUNT'; // Кол-во эл-тов типоразмера 1 pnTypeSize2ElCount = 'TYPE_SIZE_2_EL_COUNT'; // Кол-во эл-тов типоразмера 2 pnTypeSize3ElCount = 'TYPE_SIZE_3_EL_COUNT'; // Кол-во эл-тов типоразмера 3 pnTypeSize4ElCount = 'TYPE_SIZE_4_EL_COUNT'; // Кол-во эл-тов типоразмера 4 pnSquareInclEmbrasures = 'SQUARE_INCL_EMBRASURES'; //Площадь с учетом проемов pnSquareInclEmbrasuresLap = 'SQUARE_INCL_EMBRASURES_LAP'; //Площадь с учетом проемов/напусков pnOverlapping = 'OVERLAPPING'; // Перекрытие pnOverlappingLateral = 'OVERLAPPING_LATERAL'; // Перекрытие боковое pnRoofBaseRadius = 'ROOF_BASE_RADIUS'; pnCornerCount = 'CORNER_COUNT'; pnSlopeAngle = 'SLOPE_ANGLE'; //14.05.2012 - Угол наклона // Tolik 03/02/2021 -- для электрики pnNominalA = 'NOMINAL_EL'; // номинал pnMaxPower = 'MAX_POWER_EL'; // максимальная нагрузка pnPower = 'POWER_EL'; // мощность pnWireSection = 'WIRESECTION_EL'; // сечение провода(в данном случае жилы кабеля) pnAluminium = 'ALUMINIUMCABLE'; // аллюминиевый кабель (чтобы понимать, что провод НЕ медный) pnKS = 'ONETIME_KOEF_E'; // коэффициент одновременности pnKU = 'POWER_KOEF_EL'; // коэффициент мощности // pnNotUseUgoBounds = 'NOT_USE_UGO_BOUNDS';// Tolik 05/03/2021 -- //Tolik 12/11/2021 -- для труб pnFlexPipe = 'FLEXIBLE_PIPE'; // гибкая труба -- свойство трубы pnBendedPipe = 'BENDED_PIPE'; // гнутая труба -- свойство трубы pnConnectCount = 'CONNECT_COUNT'; // количество соединений -- для элемента трубного соединения // pnGUID_NB_EXCHANGE = 'GUID_NB_EXCHANGE';// Tolik 21/02/2022 -- //*** StringTipes stCataogName = 01; stCataogNameShort = 02; stComponGuidNB = 03; stComponName = 04; stComponNameShort = 05; stComponCypher = 06; stComponNotice = 07; stComponArticul = 08; stComponentTypeGUID = 09; stObjectIconGUID = 10; stProducerGUID = 11; stSuppliesKindGUID = 12; skSupplierGUID = 13; stNetTypeGUID = 14; stIzm = 15; stInterfaceGUID = 16; stInterfaceNotice = 17; stInterfaceSideSection = 18; stPropertyGUID = 19; stPropertyValue = 20; stNBConnectorGuid = 21; stNormGuidNB = 22; stNormCypher = 23; stNormName = 24; stNormWorkKind = 25; stResourceRelGuidNB = 26; stResourceRelCypher = 27; stResourceRelName = 28; stCompTypeSysNameStrings = 29; stPropValRelGUID = 30; //*** Table Indexes tiKatalog = 00; tiCatalogRelation = 01; tiComponent = 02; tiCatalogMarkMask = 03; tiCatalogPropRelation = 04; tiComponentRelation = 05; tiCompPropRelation = 06; tiCableCanalConnectors = 07; tiConnectedComponents = 08; tiInterfaceRelation = 09; tiInterfOfInterfRelation = 10; tiPortInterfaceRelation = 11; tiNorms = 12; tiNormResourceRel = 13; tiResources = 14; //--- tiCurrency = 15; tiComponentTypes = 16; tiCompTypePropRelation = 17; tiInterface = 18; tiInterfaceNorms = 19; tiInterfaceAccordance = 20; tiNetType = 21; tiNBNorms = 22; tiObjectIcons = 23; tiProducers = 24; tiProperties = 25; tiNBResources = 26; tiSuppliesKinds = 27; //--- tiCADNormStruct = 28; tiCADNormColumn = 29; tiCADCrossObject = 30; tiCADCrossObjectElement = 31; //--- tiInterfPosConnection = 32; tiProducer = 33; tiSupplier = 34; tiSuppliesKind = 35; tiStringsMan = 36; tiFilters = 37; tiPropValRel = 38; tiPropValNormRes = 39; tiObjectBlobs = 40; tiArchDefObjs = 41; // используется для хранения параметров по умолчанию арх.объектов внутри ObjectsBlobs проекта tiNormsComplete = 42; // ObjectdBlob Data kind obdkDefectAct = 1; //*** Table Names tnCableCanalConnectors = 'CABLE_CANAL_CONNECTORS'; tnCADCrossObject = 'CAD_CROSS_OBJECT'; tnCADCrossObjectElement = 'CAD_CROSS_OBJECT_ELEMENT'; tnCADNormStruct = 'CAD_NORM_STRUCT'; tnCADNormColumn = 'CAD_NORM_COLUMN'; tnCatalog = 'KATALOG'; tnCatalogMarkMask = 'CATALOG_MARK_MASK'; tnCatalogPropRelation = 'CATALOG_PROP_RELATION'; tnCatalogRelation = 'CATALOG_RELATION'; tnComponent = 'COMPONENT'; tnComponentRelation = 'COMPONENT_RELATION'; tnComponentTypes = 'COMPONENT_TYPES'; tnCompPropRelation = 'COMP_PROP_RELATION'; tnCompTypePropRelation = 'COMP_TYPE_PROP_RELATION'; tnConnectedComponents = 'CONNECTED_COMPONENTS'; tnCrossConnection = 'CROSS_CONNECTION'; tnCrossConnectionPath = 'CROSS_CONNECTION_PATH'; tnCurrency = 'CURRENCY'; tnDataType = 'DATA_TYPE'; tnDirectoryType = 'DIRECTORY_TYPE'; tnDirectoryTypeRel = 'DIRECTORY_TYPE_REL'; tnFiles = 'FILES'; tnFilters = 'FILTERS'; tnFreqUseObj = 'FREQ_USE_OBJ'; tnGradeGrid = 'GRADE_GRID'; tnInputStrings = 'INPUT_STRINGS'; tnInterface = 'INTERFACE'; tnInterfaceAccordance = 'INTERFACE_ACCORDANCE'; tnInterfaceNorms = 'INTERFACE_NORMS'; tnInterfaceRelation = 'INTERFACE_RELATION'; tnInterfaceType = 'INTERFACE_TYPE'; tnInterfOfInterfRelation = 'INTERFOFINTERF_RELATION'; tnInterfPosConnection = 'INTERF_POS_CONNECTION'; tnNetType = 'NET_TYPE'; tnNBNormResourceRel = 'NB_NORM_RESOURCE_REL'; tnNBNorms = 'NB_NORMS'; tnNBResources = 'NB_RESOURCES'; tnNorms = 'NORMS'; tnNormsComplete = 'NORMS_COMPLETE'; tnNormResourceRel = 'NORM_RESOURCE_REL'; tnObjectCurrencyRel = 'OBJECT_CURRENCY_REL'; tnObjectIcons = 'OBJECT_ICONS'; tnObjectsBlobs = 'OBJECTS_BLOBS'; tnPortInterfaceRelation = 'PORT_INTERFACE_RELATION'; tnProducers = 'PRODUCERS'; tnProjectRev = 'PROJECT_REV'; tnProperties = 'PROPERTIES'; tnPropValNormRes = 'PROP_VAL_NORM_RES'; tnPropValRel = 'PROP_VAL_REL'; tnRDBDatabase = 'RDB$Database'; tnReportSortInfo = 'REPORT_SORT_INFO'; tnReservGuid = 'RESERV_GUID'; tnResources = 'RESOURCES'; tnSettings = 'SETTINGS'; tnStringsMan = 'STRINGS_MAN'; tnSupplier = 'SUPPLIER'; tnSuppliesKinds = 'SUPPLIES_KINDS'; tnTemplateGroups = 'TEMPLATE_GROUPS'; tnTemplateRelation = 'TEMPLATE_RELATION'; tnUpdateInfo = 'UPDATE_INFO'; tnUpdateInfoRelation = 'UPDATE_INFO_RELATION'; tnUpdateStructInfo = 'UPDATE_STRUCT_INFO'; tnUserReports = 'USER_REPORTS'; // FileCodes fcSCSProjSettings = 101; // FileSectionCodes fscSCSProjSettingsProj = 1; // Установки проекта fscSCSProjSettingsList = 2; // Установки листа fscSCSProjObjectsDefParams = 3; // Параметры по умолчанию для объектов проекта // FileNames fnBufferedList = '~BufferedList.tmp'; fnDefaultListSettings = 'DefListSettings.cnf'; fnDefaultProjSettings = 'DefProjSettings.cnf'; fnExeLoader = 'ExeLoader.exe'; fnListDefSettings = 'ListDefSettings.dat'; fnLogBackupDB = 'BackupDB.log'; fnLogError = 'SCS_Errors.log'; fnLogRestoreDB = 'RestoreDB.log'; fnNB = 'NB.dat'; fnNBBackup = 'NBBack.gbk'; fnNBEmty = 'NBEmpty.dat'; fnNBComponFavorites = 'NBComponFavorites.dat'; fnNBComponFilter = 'NBComponFilter.cfr'; fNBComponGroups = 'NBComponGroups.dat'; fnObjContent = 'ObjContent.dat'; fnObjData = 'ObjData.dat'; fnObjSettings = 'ObjSettings.dat'; fnPackedTmp = '~Packed.tmp'; fnPMBlockTmp = '~PMBlock.tmp'; fnProjectTmp = '~Project.tmp'; fnProjectFilterTmp = '~ProjectFilter.tmp'; fnListCADFileTmp = 'ListCAD.tmp'; fnListCADFile = 'ListCAD'; fnProjGenerators = 'PGens.dat'; fnRepDesignLangEng = 'FR_Eng.dll'; fnRepDesignLangSpa = 'FR_Spa.dll'; fnRepDesignLangRus = 'FR_Rus.dll'; fnRepDesignLangUkr = 'FR_Ukr.dll'; {$IF Defined(SCS_PE)} fnRepDesignLang = fnRepDesignLangEng; {$ELSEIF Defined(SCS_SPA)} fnRepDesignLang = fnRepDesignLangSpa; {$ELSE} fnRepDesignLang = fnRepDesignLangRus; {$IFEND} fnReport = '~Report.tmp'; fnRepTemplateTmp = '~ReportTemplate.tmp'; fnRevision = 'REVISION'; fnTreeState = 'TreeState.dat'; fnUnPackedTmp = '~UnPacked.tmp'; // Отчеты fnReportResources = 'RResources.frf'; fnReportCable = 'RCable.frf'; fnReportCableExceedLength = 'RCableExceedLength.frf'; fnReportCableCanal = 'RCableCanal.frf'; fnReportDisparityComponColor = 'RDisparityComponColor.frf'; fnRDisparityComponProducer = 'RDisparityComponProducer.frf'; //fnRJoining = 'RJoining.frf'; fnRCableJournal = 'RCableJournal.frf'; fnRCableJournalExt = 'RCableJournalExt.frf'; fnRCablePaths = 'RCablePaths.frf'; fnRCrossConnection = 'RCrossConnection.frf'; fnRGOSTCableJournal = 'RGOSTCableJournal.frf'; fnRTypeComponents = 'RTypeComponents.frf'; fnRSpecification = 'RSpecification.frf'; fnRGOSTSpecification = 'RGOSTSpecification.frf'; fnRGOSTSpecificationA3 = 'RGOSTSpecificationA3.frf'; fnRNorms = 'RNorms.frf'; fnRExplanatoryReport = 'RExplanatoryReport.frf'; fnRLegendObjectIcons = 'RLegendObjectIcons.frf'; fnRSTAMPCable = 'RSTAMPCable.frf'; fnRSTAMPCableCanal = 'RSTAMPCableCanal.frf'; fnRSTAMPCableJournal = 'RSTAMPCableJournal.frf'; fnRSTAMPCableJournalExt = 'RSTAMPCableJournalExt.frf'; fnRSTAMPExplanatoryReport = 'RSTAMPExplanatoryReport.frf'; fnRSTAMPLegendObjectIcons = 'RSTAMPLegendObjectIcons.frf'; fnRSTAMPNorms = 'RSTAMPNorms.frf'; fnRSTAMPResources = 'RSTAMPResources.frf'; fnRMarkCable = 'RMarkCable.frf'; fnRMarkSocket = 'RMarkSocket.frf'; fnRMarkSocketPanel = 'RMarkSocketPanel.frf'; fnRMarkPathPanel = 'RMarkPathPanel.frf'; fnRMarkPathPanelPorts = 'RMarkPathPanelPorts.frf'; fnRMarkRoomTS = 'RMarkRoomTS.frf'; //added by Tolik fnRWACoordinates = 'RWACoordinates.frf'; fnRPortReport = 'RPortReport.frf'; // Tolik 31/08/2023 -- отчет по подключенным/свободным портам шкафа {$IF Not Defined(SCS_PE) and Not Defined(SCS_SPA)} fnRPriorCostOfProject = 'RPriorCostOfProject.frf'; {$ELSE} fnRPriorCostOfProject = 'RPriorCostOfProjectPE.frf'; {$IFEND} fnRCrossJournal = 'RCrossJournal.frf'; fnRExplicationRoom = 'RExplicationRoom.frf'; fnRExplicationComponent = 'RExplicationComponent.frf'; fnRGOSTCrossJournal = 'RGOSTCrossJournal.frf'; fnRSTAMPExplicationRoom = 'RSTAMPExplicationRoom.frf'; fnRSTAMPExplicationComponent = 'RSTAMPExplicationComponent.frf'; fnRDefectAct = 'RDefectAct.frf'; fnRSTAMPDefectAct = 'RSTAMPDefectAct.frf'; fnRHouse = 'RHouse.frf'; fnRSTAMPHouse = 'RSTAMPHouse.frf'; fnRCommerceInvoice = 'RCommerceInvoice.frf'; // RegKeyParamNames pnShowLicenceType = 'ShowLicenceType'; pnLicenseTypeNB = 'LicenseTypeNB'; pnServerNameNB = 'ServerNameNB'; pnLocalPathToNB = 'LocalPathToNB'; pnUserLog = 'ul'; pnUserPass = 'up'; pnPathToNB = 'PathToNB'; pnNBUser = 'NBU'; pnNBPass = 'NBP'; pnPMUser = 'PMU'; pnPMPass = 'PMP'; // Server Name snLocalHost = 'localhost'; // User Names unAdmin = 'Admin'; unSYSDBA = 'SYSDBA'; // User Pass upMasterKey = 'masterkey'; // Directory Catecory Type dctProjs = 01; dctCompons = 02; dctOtherSettings = 03; dctFilters = 04; dctBackgLayers = 05; dctArchPlans = 06; dctDXF = 07; dctPictures = 08; dctStamps = 09; dctTemp = 10; // Directory Names dnAdmin = '_Admin'; dnAutoBackup = '_AutoBackup'; dnData = 'Data'; dnDevelopment = '_Development'; dnLang = 'Lang'; dnLog = 'Log'; dnNormBase = 'NormBase'; dnRedo = 'Redo'; dnReports = 'Reports'; dnSave = 'Save'; dnSettings = 'Settings'; {$IF Defined(TELECOM)} {$IF Defined(FLASH_SCS)} dnSCS = 'TELECOM_FLASH'; {$ELSE} dnSCS = 'TELECOM'; {$IFEND} {$ELSEIF Defined(SCS_PE)} dnSCS = 'SCS_PE'; {$ELSEIF Defined(SCS_SPA)} dnSCS = 'SCS_SPA'; {$ELSE} {$IF Defined(FLASH_SCS)} dnSCS = 'SCS_FLASH'; {$ELSE} dnSCS = 'SCS'; {$IFEND} {$IFEND} dnSCSCAD = 'SCSCAD'; dnSCSUndo = 'SCSDO'; dnTemp = 'Tmp'; dnUndo = 'Undo'; dnUser = 'User'; // Extension Names {$IF Defined(ES_GRAPH_SC)} enProj = 'scg'; {$ELSE} enProj = 'scs'; {$IFEND} enBak = '.bak'; enGbk = '.gbk'; enBc3 = 'bc3'; enBlb = 'blb'; enBmp = 'bmp'; enCfr = 'cfr'; enCsv = 'csv'; enDat = 'dat'; enDoc = 'doc'; enLog = 'log'; enPdf = 'pdf'; enCompon = 'scc'; enFolder = 'scf'; enList = 'scl'; enOdt = 'odt'; enSbk = 'sbk'; enSCSProjSettings = 'sps'; enSrt = 'srt'; // SCS Report Template enTmp = 'tmp'; enUpd = 'upd'; enXls = 'xls'; // Extension Descriptions exdAll = cexdAll; exdBase = cexdBase; exdCompon = cexdCompon; exdFolder = cexdFolder; exdList = cexdList; exdComponFilter = cexdComponFilter; exdSbk = cexdSbk; exdSCSProjSettings = cexdSCSProjSettings; exdSrt = cexdSrt; exdXls = cexdXls; // Progress Cptions pcPreparingReport = CPreparingReport; ognEmpty = CEmptyObjects; // ScriptElements scelActive = 'ACTIVE'; scelAdd = 'ADD'; scelAlter = 'ALTER'; scelAs = 'AS'; scelBefore = 'BEFORE'; scelBegin = 'BEGIN'; scelBlob_SUBTYPE0_SEGMENT_SIZE80 = 'BLOB SUB_TYPE 0 SEGMENT SIZE 80'; scelCreate = 'CREATE'; scelConstraint = 'CONSTRAINT'; scelDate = 'DATE'; scelDefault = 'DEFAULT'; scelEnd = 'END'; scelFloat = 'FLOAT'; scelFor = 'FOR'; scelGenID = 'GEN_ID'; scelGenerator = 'GENERATOR'; scelIf = 'IF'; scelInsert = 'INSERT'; scelInteger = 'INTEGER'; scelISNull = 'IS NULL'; scelNew = 'NEW'; scelNotNull = 'NOT NULL'; scelPK = 'PK'; scelPosition = 'POSITION'; scelPrimaryKey = 'PRIMARY KEY'; scelSmallInt = 'SMALLINT'; scelTable = 'TABLE'; scelTime = 'TIME'; scelThen = 'THEN'; scelTrigger = 'TRIGGER'; scelVarchar40 = 'VARCHAR(40)'; scelVarchar255 = 'VARCHAR(255)'; const // Strings Names stLineGroupNodeText = cstLineGroupNodeText; stConnGroupNodeText = cstConnGroupNodeText; udUpDownCaption = cudUpDownCaption; // letter names {lnBracket = '('; lnsRBracket = '['; lnRBracket = ')'; lnRBracket = ')'; lnSpace = ' '; } // Symbol names snSpace = ' '; snPoint = '.'; snPointS = snPoint + snSpace; snComma = ','; snCommaS = snComma + snSpace; snNextRow = #10+#13; type PBoolean = ^Boolean; PDouble = ^Double; PInteger = ^Integer; PString = ^String; TItemType = integer; TString255 = String[255]; TObjectArray = array of TObject; TIntegerArray = array of Integer; TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool; stdcall; TNodeIndex = Record Index: Integer; AbsoluteIndex: Integer; end; PNodeIndex = ^TNodeIndex; TIntSet = set of 1..255; TSCSObjectKind = (okPointObject, okConnector, okLine); TComponKind = (ckCompon, ckCompl, ckNone); //*** Компонента. или комплектуюущая TTreeType = (ttComponents, ttGuide); TNBMode = (nbmNone, nbmNorm, nbmUser); TQueryMode = (qmUndef, qmPhisical, qmMemory); //*** Данные ветви папки компонентов TObjectData = record ObjectID: integer; SortID: Integer; ChildNodesCount: Integer; SkipCount: Integer; Expanded: Boolean; //HasChildren: Boolean; NBMode: TNBMode; //*** Вид узла дерева нормативной базы: нормативный или пользовательский FontColor: TColor; case TreeType: TTreeType of ttComponents: ( QueryMode: TQueryMode; ComponKind: TComponKind; //*** Компонента. или комплектуюущая ID_CompRel: Integer; //*** ID в таблице COMPONENT_RELATION , если это комплектующая case ItemType: TItemType of //*** Тип ветви (папка, ConrctorObject, LineObject, Conn-к-та, Line-к-та ) itSCSConnGroup, itSCSLineGroup: ( GroupType: String[40]; //*** Тип группы для объекта ); itList, itRoom, itSCSConnector, itSCSLine: ( ListID: Integer ) ); ttGuide: ( ); {case TreeType: TTreeType of ttComponents: ( ItemType : TItemType; //*** Тип ветви (папка, ConrctorObject, LineObject, Conn-к-та, Line-к-та ) ComponKind: TComponKind; //*** Компонента. или комплектуюущая ID_CompRel: Integer; //*** ID в таблице COMPONENT_RELATION , если это комплектующая GroupType: Integer); //*** Тип группы для объекта ttGuide: ( );} end; PObjectData = ^TObjectData; TTemplateData = record ID: Integer; IDComponent: Integer; IsLine: ShortInt; CompTypeSysName: string[40]; IsStandart: ShortInt; SortID: Integer; IconIndex: Integer; end; PTemplateData = ^TTemplateData; {TInterfTypeData = record ID: Integer; ChildNodesCount: Integer; Sort_ID: Integer; end; PInterfTypeData = ^TInterfTypeData;} TCallFrom = (cfBase, cfCAD); TClickCount = (ccOne, ccDouble); TProjPart = (ppPM, PPCAD); TWhoChange = (wcTree, wcGrid, wcNone); TInputFormMode = (imInputText, imInputFloat, imInputCombo, imChoiceAddCompl, imListForTree, imChoiceDelComponMode); TDelComponMode = (dmArea, dmTrace, dmNone); TInputBoxListKind = (lkComponObjectData, lkComponID, lkComponComplect, lkBusyInterfaces); TTreeKind = (trkCatalog, trkGuide); TPropKind = (pkNoneProp, pkCatalog, pkCompon, pkCompTypePropRel); TDBKind = (bkNone, bkNormBase, bkProjectManager); TFormMode = (fmNone, fmMake, fmEdit, fmView, fmDisabled); TResourceReportFormMode = (fmUnsign, fmRObject, fmRResources, fmRNorms, fmRCable, fmRCableExceedLength, fmRCableCanal, fmRDisparityComponColor, fmRDisparityComponProducer, fmRCableJournal, fmRCableJournalExt, fmRCablePaths, fmRGOSTCableJournal, fmRLegendObjectIcons, fmRTypeComponents, fmRSpecification, fmRGOSTSpecification, fmRGOSTSpecificationA3, fmRExplanatoryReport, fmRPriorCostOfProject, fmRExplicationRoom, fmRExplicationComponent, fmRCrossJournal, fmRGOSTCrossJournal, fmCommerceInvoice, fmRDefectAct, fmRHouse, fmCompoSpecification, fmRCrossConnection, fmRMarkRoomTS, fmRMarkPathPanel, fmRMarkPathPanelPorts, fmRMarkSocket, fmRMarkSocketPanel, fmRMarkCable, fmWACoordinates, fmPortReport{Tolik 31/08/2023 -- отчет по подключенным/свободным портам шкафа}); PResourceReportFormMode = ^TResourceReportFormMode; TReportUseKind = (rkProject, rkCalc, rkMarkPages, rkCablePath, rkCrossConnection, rkWACoordinates, rkPortReport); TReportUseKinds = set of TReportUseKind; TBackupRestoreFormMode = (fmBackUp, fmRestore); TMasterUpdatePriceMode = (fmUpdateCompons, fmImportResources, fmImportNorms); TComplectFormMode = (cmAdd, cmEdit); TShowMessageType = (smtNone, smtDisplay, smtProtocol, smtLog); TViewType = (vtDir, vtComponent, vtAuto); TEditKind = (ekCopy, ekCut, ekNone); TMoveType = (mtUp, mtDown); TDropMenuResult = (dmMove, dmAddLink, dmCancel); TAnimateInclude = (aiProgressBar, aiStatusBar, aiNone); TStartStop = (ssStart, ssStop); TViewKind = (vkNone, vkAll, vkProperty, vkInterface, vkInterfaceAccordance, vkInterfaceNorms, vkCurrency, vkNetType, vkProducers, vkObjectIcons, vkComponentType, vkNorm, vkResource, vkTZ, vkSuppliesKind, vkUnitsOfMeasure, vkDimensions, vkCompSpecifications); TSprElements = set of TViewKind; //TParam = (tMake, tEdit, tView); TModeConnectDisconnect = (mcdConnect, mcdDisconnect); TModeConnDisconnCompons = (cdConnlineCompons, cdDisConnlineCompons, cdConnConCompons, cdDisConnConCompons, cdCablesNoInCanals); TCompStateType = (stProjectible, stActing); TMakeEdit = (meMake, meEdit, meDel, {meAdd, }meNone); TAppendRemove = (arAppend, arRemove); TTableKind = ( tkCableCanalConnectorsED, tkComplectED, tkCompPropRelED, tkCrossConnectionED, tkPortInterfRelED, tkInterfInternalConnED, tkPropertyRelED, tkInterfRelED, tkIOfIRelED, tkPortEd, tkComponIconsED, tkCatalog, tkComponent, tkCompTypePropRelation, tkCurrency, tkInterfRel, tkIOfIRel, tkPort, tkComplect, tkPropertyRel, tkComponentTypes, tkProperty, tkNetType, tkProducers, tkComponIcons, tkCompStateType, tkObjectIcon, tkSuppliesKind, tkInterface, tkInterfaceAccordance, tkDirectoryType, tkDirectoryTypeRel, tkNBNorm, tkNorm, tkResourceRel, tkResource, tkNormEd, tkResourceRelEd, tkResourceEd ); //type TGender = (gtFamale = 0, gtMale = 1); //*** Типы соединений компонентов //*** Виды соединений интерфейсов {type TConnectKind = (ckFemaleMale=1, // мама-папа ckMaleFemale, // папа-мама ckFemaleFemale, // мама-мама ckMaleMale, // папа-папа ckSingle, // пол одинаковый ckVarious // пол разный );} TCanConnectKind = (cckAuto, cckManual, cckNone); TCheckInterfForUnionResult = (chrSuccess, chrFail, chrSameMult, chrVariousMult, chrInterfConnected, chrFailInterfaces, chrFailGenders, chrFailSideSection, chrBusy); TCheckInterfForUnionElement = (ciueInterfConnected); TCheckInterfForUnionElements = set of TCheckInterfForUnionElement; TQueryType = (qtNone, qtSelect, qtInsert, qtUpdate, qtDelete); TOpenBaseResult = (obrNone, obrFoul, obrSuccess, obrInUse, obrNoBases, obrOldStructure, obrNoProperBases, obrRemoteBases, obrBusyMode, obrFailProgramBaseType); TOpenProjectState = (opsFoul, opsSuccessful, opsInUse, opsNoEnoughGDI); TopenProjectResult = record OpenProjectState: Set of TOpenProjectState; UserName: String; UserDateTime: TDateTime; end; TOpenCatalogFromFileResult = (ocrSuccessful, ocrFileNotFound, ocrFoulItemType, ocrBadFormat, orcIsOldRelease, orcFailAccess); TListHeightProps = (lhpNone, lhpHeightRoom, lhpHeightCeiling, lhpHeightSocket, lhpHeightCorob); //type TResourceReportType = (rrtObjectReport, rrtCommon); TFillConnectConObj = (foNone, foEmpty, foBusy, foPartEmpty); TQueryOperation = (qoNone, qoSelect, qoInsert, qoUpdate, qoDelate); TSQLIdentifyKind = (ikOperation, ikSelFields, ikSelFrom, ikSelTableNames, ikInsInto, ikInsTableName, ikInsOpenFldBracket, ikInsFields, ikInsValues, ikInsOpenValBracket, ikInsFldValues, ikUpdTableName, ikUpdSet, ikUpdField, ikUpdEquals, ikUpdValue, ikDelFrom, ikDelTableName, ikDelWhere, ikWhere); // Tolik 12/03/2020 //TPrintDevice = (pdPrinter, pdScreen, pdDesign, pdExcel, pdPdf); TPrintDevice = (pdPrinter, pdScreen, pdDesign, pdExcel, pdPdf, pdExcel2007, pdWord2007); // TTraceTypePorition = (tpVertical, tpHorizontal, tpIncline); TCheckReplaceComponResult = (crcrSuccessful, crcrBadFunctionalInterfaces, crcrBadContructiveInterfaces, crcrCannotComplectToParentByParams, crcrCannotComplectChildrenByParams, crcrSmallCanal); TCheckReplaceComponResults = Set Of TCheckReplaceComponResult; TNormResourcesKind = (nrNorms, nrResources, nrAccessories, nrComponents, nrAll); TNormResourcesKinds = set of TNormResourcesKind; TTreeSortType = (tstText, tstSortID); TOpenProjectMode = (opmStandart, opmReserv, opmBeatens); TScrollType = (stHLeft, stHRight, stVUp, stVDown); TArtNoType = (antNone, antProduc, antDistrib); TMemBaseMode = (mbmSQLMemTable, mbmFiles); TFilterType = (fltNone, fltCustom, fltFavorites, fltTop); //TMemTable = record // Table: TSQLMemTable; //end; //**** INI TCommonIni = record DBPath: String[255]; PnAdditionRestored: Boolean; end; TNBIni = record Common: TCommonIni; ControlJoinByNetType: Boolean; ComplectControlByProducer: Boolean; ControlJoinByProperties: Boolean; ControlComplectByProperties: Boolean; DisableEdit: Boolean; IsAdministration: Boolean; IDLastNBDir: Integer; ColorZeroPriceComponent: Integer; FilterType: TFilterType; IsUseFilter: Boolean; RemindToBackUpBase: Boolean; RemindToBackUpBaseTime: Integer; CurrencyConvertionNB2PM: ShortInt; //23.08.2012 - Способ ковертации валют при размещении на проект из НБ AutoShowParams: Boolean; LicenseTypeInt: integer; ServerName: string; LocalPathToNB: string; SaveConnParams: Boolean; end; TPMIni = record Common: TCommonIni; IDLastProject: Integer; RepDesignLanguageFile: string[255]; // имя dll файла настройки языка в фастрепорт NBLineComponGUIDForConfigurator: string[40]; //GUID линейной компоненты для конфигуратора подключений RepPricePrecision: Integer; RepKolvoPrecision: Integer; SaveConnParams: Boolean; end; TControlsIni = record F_SCSMain_IsPanelExpertMode: Boolean; end; TColorsInfo = record Active: Boolean; Back: TColor; Font: TColor; end; PColorsInfo = ^TColorsInfo; TColorObjectsIni = record Resource: TColorsInfo; ResourceCompon: TColorsInfo; Norm: TColorsInfo; TotalKolvo: TColorsInfo; end; TEnvironmentsIni = record TempDir: String; end; TSCSIni = record NB: TNBIni; PM: TPMIni; Controls: TControlsIni; Colors: TColorObjectsIni; Environments: TEnvironmentsIni; end; TBaseConnectParams = record UserName: String[100]; Pass: String[100]; end; TMemValue = record // Tolik 20/12/2019 -- не используется нигде ID: Integer; FieldName: String; DataType: TFieldType; Int: Integer; Str: String; Float: Double; Blob: TStream; end; PMemValue = ^TMemValue; TMemField = record // не юзается ниде ID: Integer; Name: String; FieldDef: TFieldDef; TableInfo: TObject; Operation: TQueryOperation; Value: PMemValue; end; PMemField = ^TMemField; TMemParam = record // не юзается ниде FieldName: String; MemField: PMemField; MemValue: PMemValue; end; PMemParam = ^TMemParam; // не юзается ниде TFillConnectLineObj = record FillingSide1: TFillConnectConObj; FillingSide2: TFillConnectConObj; end; TCanFemaleHaveMaleRes = record CanHave: Boolean; CurrFemaleEmptyValue: Double; CurrMaleValue: Double; MaxFemaleFullValue: Double; //*** Максимальное значение, позволяющ. вместить пап MinValueForMales: Double; //*** Требуемое значенте для вмещаемости пап end; TConnFigureParams = record ListID: Integer; FigureID: Integer; Fullness: TComponInterfacesFullness; DefectObjDegree: TDefectDegree; end; PConnFigureParams = ^TConnFigureParams; TLineFigureParams = record ListID: Integer; FigureID: Integer; FullnesCableSide1: TComponInterfacesFullness; FullnesCableSide2: TComponInterfacesFullness; ClosedTypeForChannelSide1: TComponInterfacesFullness; ClosedTypeForChannelSide2: TComponInterfacesFullness; ChannelFullness: TComponInterfacesFullness; DefectObjDegree: TDefectDegree; end; PLineFigureParams = ^TLineFigureParams; TResourceType = Integer; TGenderType = integer; TComponType = integer; TConnectKind = Integer; TConnectType = Integer; TInterfType = Integer; TPortKind = Integer; PList = ^Tlist; {TComponData = record ID: Integer; Name: String; isLine: Integer; Kol_Complect: Integer; Sort_Id: Integer; end;} TComponData = record ID: Integer; GuidNB: Integer; Name: Integer; NameShort: Integer; //MarkStr: String; Cypher: Integer; Izm: Integer; Notice: Integer; Description: String[40]; Picture: String[40]; Color: Integer; ISComplect: SmallInt; IsLine: SmallInt; IsTemplate: ShortInt; PriceSupply: Double; Price: Double; PriceCalc: Double; UserLength: Double; MaxLength: Double; ObjectIconStep: Double; HasNDS: Integer; ArticulDistributor: Integer; ArticulProducer: Integer; IDComponentType: Integer; IDSymbol: Integer; IDObjectIcon: Integer; IDProducer: Integer; IDCurrency : Integer; IDSuppliesKind: Integer; IDSupplier : Integer; IDNetType: Integer; SortID: integer; KolComplect: Integer; CableCanalConnectorsCnt: Integer; InterfCount: Integer; JoinsCount: Integer; NormsCount: Integer; PropsCount: Integer; ResourcesCount: Integer; IDNormBase: Integer; ObjectID: Integer; ListID: Integer; IDRelatedCompon: Integer; WholeID: Integer; IsDismount: Integer; IsUseDismounted: Integer; UseKindInProj: Integer; NameMark: String[200]; MarkID: Integer; IsUserMark: Integer; IsMarkInCaptions: Integer; ComeFrom: Integer; GUIDComponentType: Integer; GUIDSymbol: Integer; GUIDObjectIcon: Integer; GUIDProducer: Integer; GUIDSuppliesKind: Integer; GUIDSupplier: Integer; GUIDNetType: Integer; end; TCompDataFlag = ( cdNone, cdComplects, cdCableCanalConnectors, cdConections, cdCrossConnections, cdProperties, cdInterfaces, cdIOfIRels, cdComponentType, cdNorms, cdResources, cdCalcResCost, cdAll ); TCompDataFlags = set of TCompDataFlag; TDefineObjectParam = (dopJoinedTrunk, dopTrunkChanged, dopLengthNearPointObject, dopStatus, dopIcon, dopMark); TDefineObjectParams = Set of TDefineObjectParam; TInterfRelData = record ID: Integer; Npp: Integer; IDInterface: Integer; IDComponent: Integer; TypeI : Integer; Kind: Integer; IsPort: Integer; IsUserPort: Integer; NppPort: Integer; IDConnected: integer; Gender: Integer; Multiple: Integer; IsBusy: Integer; NumPair: Integer; Color: Integer; IDAdverse: Integer; Side: Integer; Notice: Integer; SortID: Integer; Kolvo: Integer; KolvoBusy: Integer; //*** Количество занятых интерфейсов - может превышать реальное количество при многократном подключении SignType: Integer; ConnToAnyGender: ShortInt; SideSection: Integer; GUIDInterface: Integer; IOfIRelCount: Integer; PortInterfRelCount: Integer; ValueI: Double; CoordZ: Double; end; TIOfIRelData = record ID: Integer; IDInterfRel: Integer; IDInterfTo: Integer; IDCompRel: Integer; IDIOfIRelMain: Integer; PosConnectionsCount: Integer; //18.01.2014 end; TInterfPosConnectionData = record ID: Integer; IDIOIRel: Integer; SelfFromPos: Integer; SelfToPos: Integer; ConnFromPos: Integer; ConnToPos: Integer; end; TPortInterfRelData = record ID: Integer; RelType: Integer; IDPort: Integer; IDInterfRel: Integer; UnitInterfKolvo: Integer; end; TmeInterfaceRel = record //** me -> Make&Edit ID: Integer; ID_COMPONENT: Integer; IsLineCompon: Integer; ID_INTERFACE: Integer; Npp: Integer; Name: String[255]; TypeI: Integer; Kind: Integer; IsNative: Boolean; IsPort: Integer; IsUserPort: Integer; NppPort: Integer; NumPair: Integer; Gender: Integer; Multiple: Integer; IsBusy: Integer; ValueI: Double; Kolvo: Integer; SORT_ID: Integer; Color: Integer; ID_Adverse: Integer; Side: Integer; Notice: String; SignType: Integer; ConnToAnyGender: ShortInt; SideSection: string[200]; GUIDInterface: string[40]; Count: Integer; ServiceIsPair: Boolean; ServiceApplyForAllNoRelPorts: Boolean; ServiceShowApplyForAllNoRelPorts: Boolean; DataSource: TDataSource; mtInterfaces: TkbmMemTable; mtPorts: TkbmMemTable; mtPortInterfRel: TkbmMemTable; mtInterfInternalConnect: TkbmMemTable; end; PmeInterfaceRel = ^TmeInterfaceRel; {TInterfaceRelData = record ID: Integer; ID_Interface: Integer; ID_Component: Integer; TypeI: Integer; Gender: Integer; Multiple: Integer; IsBusy: Integer; end; PInterfaceRelData = ^TInterfaceRelData;} //**** SCSComponent Records TCatalog = record ID: integer; Parent_ID: Integer; //Project_ID: Integer; List_ID: Integer; Name: String[255]; NameShort: String[200]; NameMark: String[200]; IsUserName: Integer; Sort_ID: Integer; Kol_Compon: Integer; ItemsCount: Integer; ItemType: TItemType; MarkID: Integer; Scs_ID: Integer; IsIndexWithName: integer; IndexPointObj: integer; IndexConnector: integer; IndexLine: integer; BuildID: Integer; NBBuildID: Integer; OpenedInCAD: Boolean; end; PCatalog = ^TCatalog; TCatalogData = record ID: integer; ParentID: Integer; //Project_ID: Integer; ListID: Integer; Name: Integer; NameShort: Integer; NameMark: String[200]; IsUserName: Integer; SortID: Integer; KolCompon: Integer; ItemsCount: Integer; ItemType: TItemType; MarkID: Integer; ScsID: Integer; IsIndexWithName: integer; IndexPointObj: integer; IndexConnector: integer; IndexLine: integer; PropsCount: Integer; NormsCount: Integer; ResourcesCount: Integer; //BuildID: Integer; //OpenedInCAD: Boolean; RoomSetting: string[40]; ListSetting: Integer; end; TCatalogRelation = record IDCatalog: Integer; IDComponent: Integer; end; PCatalogRelation = ^TCatalogRelation; TCatalogRelationData = record IDCatalog: Integer; IDComponent: Integer; end; TCatalogMarkMask = record ID: Integer; IDCatalog: Integer; IDComponentType: Integer; MarkMask: String[200]; //*** Служебные поля MakeEdit: TMakeEdit; end; PCatalogMarkMask = ^TCatalogMarkMask; TComplect = record ID: Integer; NewID: Integer; //*** Новый ID после сохранения ID_Component: Integer; ID_NewComponent: Integer; ID_Child : Integer; ID_NewChild: Integer; IDTopComponent: Integer; IDParentCompRel: Integer; KolSubComplect: Integer; SortID: Integer; Kolvo: Integer; ConnectType: TConnectType; RelType: ShortInt; Fixed: ShortInt; ServCopyIndex: Integer; end; PComplect = ^TComplect; TCompRelData = Record ID: Integer; IDComponent: Integer; IDChild: Integer; Kolvo: Integer; ConnectType: Integer; RelType: ShortInt; Fixed: ShortInt; SortID: Integer; end; TConnectedComponsData = record ID: Integer; ComponWholeID: Integer; IDConnectObject: Integer; IDConnectCompon: Integer; IDSideCompon: Integer; TypeConnect: Integer; end; {TCrossConnection = record ID: Integer; IDComponent: Integer; IDComponFrom: Integer; IDComponTo: Integer; IDComponWith: Integer; IDCompRelFrom: Integer; IDCompRelTo: Integer; IDCompRelWith: Integer; NameFrom: string[255]; NameTo: string[255]; NameWith: string[255]; NppFrom: Integer; NppTo: Integer; NppWith: Integer; IsNew: Boolean; IsModified: Boolean; end; PCrossConnection = ^TCrossConnection;} TProperty = Record Guid: String; ID: Integer; ID_Property: Integer; GUIDProperty: String; IDMaster: Integer; IDDataType: Integer; TakeIntoConnect: Integer; TakeIntoJoin: Integer; IsTakeJoinforPoint: Integer; IsCrossControl: Integer; IDCrossProperty: Integer; GUIDCrossProperty: String; Name_: String; SysName: String; Value: String; IsDefault: Integer; IsForWholeComponent: Integer; NewID: Integer; IsNew: Boolean; IsModified: Boolean; end;{ TProperty = Record Guid: String; ID: Integer; NewID: Integer; ID_Property: Integer; GUIDProperty: String; IDMaster: Integer; IDDataType: Integer; IDCrossProperty: Integer; GUIDCrossProperty: String; Name: String; SysName: String; Value: String; TakeIntoConnect: ShortInt; TakeIntoJoin: ShortInt; IsTakeJoinforPoint: ShortInt; IsCrossControl: ShortInt; IsDefault: ShortInt; IsForWholeComponent: ShortInt; IsNew: Boolean; IsModified: Boolean; end;} PProperty = ^TProperty; TComponPropData = Record ID: Integer; IDProperty: Integer; GUIDProperty: Integer; IDComponent: Integer; TakeIntoConnect: ShortInt; TakeIntoJoin: ShortInt; IsTakeJoinforPoint: ShortInt; IsCrossControl: ShortInt; IDCrossProperty: Integer; GUIDCrossProperty: Integer; Value: Integer; end; TCatalogPropData = Record ID: Integer; IDProperty: Integer; GUIDProperty: Integer; IDCatalog: Integer; Value: Integer; IsDefault: ShortInt; end; TComponTypePropData = Record GuidComponentType: Integer; Guid: string[40]; ID: Integer; IDComponType: Integer; IDProperty: Integer; GUIDProperty: Integer; TakeIntoConnect: ShortInt; TakeIntoJoin: ShortInt; Value: Integer; IsStandart: Integer; end; TPropertyData = record ID: Integer; GUID: String[40]; IDDataType: Integer; Name: String[255]; SysName: String[200]; Izm: String[200]; ValueReq: Integer; MinValue: Double; MaxValue: Double; DefValue: String[255]; Description: String[255]; IsStandart: Integer; SortID: Integer; IDItemType: Integer; ISProject: Integer; ISFolder: Integer; ISList: Integer; ISRoom: Integer; ISSCSLine: Integer; ISSCSConnector: Integer; ISComponLine: Integer; ISComponConn: Integer; IsForWholeComponent: Integer; IsValueRelToObj: ShortInt; end; PPropertyData = ^TPropertyData; TPropValRelData = record ID: Integer; GUID: String[cnstGUIDLength]; IDProperty: Integer; GuidProperty: String[cnstGUIDLength]; PValue: String[255]; MinValue: String[255]; MaxValue: String[255]; end; PPropValRelData = ^TPropValRelData; TPropValRelBuffData = record ID: Integer; GUID: Integer; IDProperty: Integer; GuidProperty: Integer; PValue: Integer; MinValue: Integer; MaxValue: Integer; PropValNormResCount: Integer; end; PPropValRelBuffData = ^TPropValRelBuffData; TPropValNormResData = record ID: Integer; GUID: String[cnstGUIDLength]; IDPropValRel: Integer; GuidPropValRel: String[cnstGUIDLength]; IDNBComponent: Integer; GuidNBComponent: String[cnstGUIDLength]; IDNBRes: Integer; GuidNBRes: String[cnstGUIDLength]; IDNBNorm: Integer; GuidNBNorm: String[cnstGUIDLength]; Name: String[255]; Kolvo: Double; ExpenseForLength: Double; CountForPoint: Double; StepOfPoint: Double; end; PPropValNormResData = ^TPropValNormResData; TPropValNormResBuffData = record ID: Integer; GUID: String[cnstGUIDLength]; IDPropValRel: Integer; GuidPropValRel: Integer; IDNBComponent: Integer; GuidNBComponent: Integer; IDNBRes: Integer; GuidNBRes: Integer; IDNBNorm: Integer; GuidNBNorm: Integer; Kolvo: Double; ExpenseForLength: Double; CountForPoint: Double; StepOfPoint: Double; end; PPropValNormResBuffData = ^TPropValNormResBuffData; TPropertyBuffData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; IDDataType: Integer; Name: String[255]; SysName: String[200]; Izm: String[200]; ValueReq: Integer; MinValue: Double; MaxValue: Double; DefValue: String[255]; Description: String[255]; IsStandart: Integer; SortID: Integer; IDItemType: Integer; ISProject: Integer; ISFolder: Integer; ISList: Integer; ISRoom: Integer; ISSCSLine: Integer; ISSCSConnector: Integer; ISComponLine: Integer; ISComponConn: Integer; IsForWholeComponent: Integer; IsValueRelToObj: ShortInt; PropValRelCount: Integer; end; TPropertyNamesInfo = record ID_Property: Integer; GUIDProperty: String[40]; Name: String[255]; SysName: String[200]; IsForWholeComponent: Integer; end; PPropertyNamesInfo = ^TPropertyNamesInfo; TResourceRelData = record IDResource: Integer; GuidNB: Integer; IDNB: Integer; TableKindNB: Integer; Cypher: Integer; Name: Integer; Izm: Integer; Price: Double; AdditionalPrice: Double; RType: Integer; ID: Integer; MasterTableKind: Integer; IDMaster: Integer; IDCompPropRel: Integer; Npp: Integer; Kolvo: Double; Cost: Double; IsOn: Integer; ExpenseForLength: Double; //ExpenseForSection: Double; GUIDNBComponent: Integer; CountForPoint: Double; StepOfPoint: Double; end; TNormData = record ID: integer; GuidNB: integer; IDNB: integer; Cypher: integer; MasterTableKind: integer; Name: integer; WorkKind: integer; Izm: integer; IDMaster: integer; IDCompPropRel: Integer; Npp: integer; IsOn: integer; LaborTime: Integer; PricePerTime: Double; Price: Double; Cost: Double; Kolvo: Double; TotalCost: Double; IsFromInterface: integer; ExpenseForLength: Double; //ExpenseForSection: Double; CountForPoint: Double; StepOfPoint: Double; end; TProducer = record ID: Integer; GUID: String[40]; Name: String[255]; Description: String[255]; end; PProducer = ^TProducer; TProducerData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; Description: String[255]; end; { TComponentType = record ID: Integer; GUID: String[40]; Name: String[255]; NamePlural: String[255]; SysName: String[100]; MarkMask: String[200]; PortKind: Integer; ActiveState: Integer; IDDesignIcon: Integer; GUIDDesignIcon: String[40]; IsLine: Integer; IsStandart: Integer; CoordZ: Double; IDComponTemplate: Integer; ComponentIndex: Integer; end; } TComponentType = record ID: Integer; GUID: String; Name: String; NamePlural: String; SysName: String; MarkMask: String; PortKind: Integer; ActiveState: Integer; IDDesignIcon: Integer; GUIDDesignIcon: String; IsLine: Integer; IsStandart: Integer; CoordZ: Double; IDComponTemplate: Integer; ComponentIndex: Integer; CanUseAsPoint: ShortInt; end; PComponentType = ^TComponentType; TComponentTypeData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; NamePlural: String[200]; SysName: Integer; MarkMask: String[200]; PortKind: Integer; ActiveState: Integer; IDDesignIcon: Integer; GUIDDesignIcon: Integer; IsLine: Integer; IsStandart: Integer; CoordZ: Double; IDComponTemplate: Integer; ComponentIndex: Integer; CanUseAsPoint: ShortInt; PropsCount: Integer; end; TComponentTypeTmp = record ID: Integer; GUID: String; Name: String; NamePlural: String; SysName: String; MarkMask: String; PortKind: Integer; ActiveState: Integer; IDDesignIcon: Integer; GUIDDesignIcon: String; IsLine: Integer; IsStandart: Integer; CoordZ: Double; IDComponTemplate: Integer; ComponentIndex: Integer; end; PComponentTypeTmp = ^TComponentTypeTmp; TComponIcon = Record ID: Integer; ID_ObjectIcon: Integer; end; PComponIcon = ^TComponIcon; TSuppliesKind = record ID: Integer; GUID: String[40]; Name: String[255]; NameTradUOM: String[255]; Izm: String[255]; IzmTradUOM: String[255]; UnitKolvo: Double; UnitKolvoTradUOM: Double; end; PSuppliesKind = ^TSuppliesKind; TSuppliesKindData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; NameTradUOM: String[255]; Izm: String[255]; IzmTradUOM: String[255]; UnitKolvo: Double; UnitKolvoTradUOM: Double; end; TNetType = record ID: Integer; GUID: string[40]; Name: String[255]; end; PNetType = ^TNetType; TNetTypeData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; end; {PInterface = ^TInterface; TInterface = Record ComponentOwner: TObject; ID: Integer; NewID: Integer; NewIDAdverse: Integer; Npp: Integer; ID_Interface: Integer; ID_Component: Integer; ID_NewComponent: Integer; IsLineCompon: Integer; TypeI : Integer; Kind: Integer; IsPort: Integer; IsUserPort: Integer; NppPort: Integer; IDConnected: integer; Gender: Integer; Multiple: Integer; IsBusy: Integer; ValueI: Double; CoordZ: Double; NumPair: Integer; Color: Integer; IDAdverse: Integer; Side: Integer; Notice: String[255]; SortID: Integer; GUIDInterface: string[40]; //IOfIRel: TList; IOfIRelOut: TList; //IOfIRelIn: TList; ConnectedInterfaces: TList; //*** PInterfaces ParallelInterface: PInterface; ServCanConnect: Boolean; end; } TInterfaceInfo = record ID: Integer; GUID: string[40]; Name: String[255]; ConstructiveWidth: Double; IDNetType: Integer; Description: String[255]; IsVisible: Integer; IsUniversal: ShortInt; end; PInterfaceInfo = ^TInterfaceInfo; TInterfaceData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; GUIDNetType: Integer; IDNetType: Integer; SortID: Integer; ConstructiveWidth: Double; Description: String[255]; IsUniversal: ShortInt; InterfAccordanceCount: Integer; InterfNormsCount: Integer; end; TInterfaceAccordanceInfo = record ID: Integer; GUID: string[40]; IDInterface: Integer; InterfComponIsLine: Integer; IDAccordance: Integer; AccordComponIsLine: Integer; Kolvo: Integer; end; PInterfaceAccordanceInfo = ^TInterfaceAccordanceInfo; TInterfaceAccordanceData = record ID: Integer; GUID: string[40]; GUIDInterface: Integer; IDInterface: Integer; InterfComponIsLine: Integer; IDAccordance: Integer; AccordComponIsLine: Integer; Kolvo: Integer; end; TInterfaceNormInfo = record ID: Integer; GUID: String[40]; IDInterface: Integer; IDNBNorm: Integer; GUIDNBNorm: String[40]; Expense: Double; IDComponentType: Integer; InterfaceIsBusy: Integer; KoefLengthForCompl: Double; //*** дополнительная инфа о интерфейсе InterfaceType: Integer; SCSComponent: TObject; RelationComponent: TObject; // Tolik -- 22/06/2016 -- Guid_Interface: string; // end; PInterfaceNormInfo = ^TInterfaceNormInfo; TInterfaceNormData = record ID: Integer; GUID: String[40]; GuidInterface: Integer; IDInterface: Integer; IDNBNorm: Integer; GUIDNBNorm: Integer; Expense: Double; GUIDComponentType: Integer; IDComponentType: Integer; InterfaceIsBusy: Integer; KoefLengthForCompl: Double; ////*** дополнительная инфа о интерфейсе //InterfaceType: Integer; end; TNormCableColumn = record Name: String; GUID: String; PairKolvo: Integer; Value: Double; end; PNormCableColumn = ^TNormCableColumn; TNormResourceColumnIndex = record ResourceComponent: TObject; ColumnIndex: Integer; Kolvo: Integer; Kolvos: TIntList; ComponIDs: TIntList; end; PNormResourceColumnIndex = ^TNormResourceColumnIndex; TInterfaceAccordance = record IDInterface1: Integer; IDInterface2: Integer; IsLine1: Integer; IsLine2: Integer; end; PInterfaceAccordance = ^TInterfaceAccordance; TNormInfo = record ID: Integer; GUID: String[40]; Cypher: String[255]; Name: String[255]; Izm: String[200]; LaborTime: Integer; PricePerTime: Double; //TimeUOM: Integer; Price: Double; GUIDESmeta: String[40]; end; PNormInfo = ^TNormInfo; TNBNormData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Cypher: Integer; Name: Integer; Izm: Integer; LaborTime: Integer; PricePerTime: Double; //TimeUOM: Integer; Price: Double; GUIDESmeta: String[40]; end; TResourceInfo = record ID: Integer; GUID: String[40]; Cypher: String[255]; Name: String[255]; Izm: String[200]; Price: Double; RType: Integer; end; PResourceInfo = ^TResourceInfo; TResourceData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Cypher: Integer; Name: Integer; Izm: Integer; Price: Double; RType: Integer; end; TIOfIRel = record ID: Integer; NewID: Integer; IDInterfRel: Integer; IDInterfTo: Integer; IDCompRel: Integer; InterfaceTo: TObject; //PInterface; //*** Service fileds NewIDInterfRel : Integer; NewIDInterfTo : Integer; //*** Служебные данные для IDCompRel NewIDCompon: Integer; NewIDChild: Integer; end; PIOfIRel = ^TIOfIRel; // end TSCSCompon Records***** {TIOfIRel = record ID: Integer; IDInterfRel: Integer; IDInterfTo: Integer; IDCompRel: Integer; end; PIOfIRel = ^TIOfIRel; } TIDAndName = record ID: Integer; NAME: String[255]; end; PIDAndName = ^TIDAndName; TDirTypeInfo = record ViewKind: TViewKind; ItemType: Integer; MasterFieldName: String[50]; TableName: String[50]; TableCaption: String[100]; TableCaptionPlural: String[100]; FldName: String[50]; DataSet: TDataSet; DataSrc: TDataSource; end; TDirectoryType = record ID: Integer; ParentID: Integer; Name: String[255]; ItemsCount: Integer; ContentKolvo: Integer; SortID: Integer; end; PDirectoryType = ^TDirectoryType; TDirectoryTypeRel = record ID_Pointer: Integer; ID_DirecoryType: Integer; end; PDirectoryTypeRel = ^TDirectoryTypeRel; TCableCanalConnector = record ID: Integer; IDCableCanal: Integer; IDNBConnector: Integer; GuidNBConnector: String[40]; ConnectorType: Integer; NewID: Integer; IsNew: Boolean; IsModified: Boolean; end; PCableCanalConnector = ^TCableCanalConnector; TCableCanalConnectorData = record ID: Integer; IDCableCanal: Integer; IDNBConnector: Integer; GuidNBConnector: Integer; ConnectorType: Integer; end; TStringsManInfo = record ID: Integer; StrType: Integer; Name: string[255]; end; PStringsManInfo = ^TStringsManInfo; TStringsManData = record ID: Integer; StrType: Integer; Name: string[255]; end; TObjectBlobData = record ID: Integer; TableKind: Integer; ObjIDs: Integer; DataKind: Integer; ObjectData: Integer; end; TCurrency = Record ID: Integer; GUID: String[40]; Name: String[255]; NameBrief: String[255]; Kolvo: Integer; Ratio :Double; IsCountry: Integer; Main: Integer; end; PCurrency = ^TCurrency; TCurrencyData = Record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: String[40]; Name: String[255]; NameBrief: String[255]; Kolvo: Integer; Ratio :Double; IsCountry: Integer; Main: Integer; end; TObjectCurrencyRel = Record ID: Integer; GUID: String[40]; IDCurrency: Integer; IDCatalog: Integer; Data: TCurrency; //Name: String[255]; //NameBrief: String[255]; //Kolvo: Integer; //Ratio :Double; //Main: Integer; end; PObjectCurrencyRel = ^TObjectCurrencyRel; TConnectInterfRes = record CanConnect: Boolean; ConnectInterfCount: Integer; NewIDCompRel: Integer; CompRel: PComplect; ComponObj1: TObject; ComponObj2: TObject; Compon1Count: Integer; Compon2Count: Integer; end; TCrossConnectRes = record Successful: Boolean; ConnectCount: Integer; end; TNewOldID = record OldID: Integer; NewID: Integer; Analyzed: Boolean; end; PNewOldID = ^TNewOldID; TInterfLists = record InterfList1: Tlist; InterfList2: Tlist; end; PInterfLists = ^TInterfLists; TConnectListData = record Data1: Pointer; Data2: Pointer; end; PConnectListData = ^TConnectListData; TConnectObjectParam = record IDObject: Integer; Side: Integer; end; PConnectObjectParam = ^TConnectObjectParam; TConnectedObjectsSides = record IDObj1, IDObj2: Integer; Side1, Side2: Integer; end; PConnectedObjectsSides = ^TConnectedObjectsSides; TIDAndCaption = Record Caption: String[255]; ID: Integer; end; PIDAndCaption = ^TIDAndCaption; TWholeLineCompon = record WholeCompon: TIntList; WholeComponObj: TObject; FirstIDCompon: Integer; //*** конечный компонент 1 FirstCompon: TObject; LastIDCompon: Integer; //*** конечный компонент 2 LastCompon: TObject; //*** подсоединенные точечные компоненты FirstIDConnectedConnCompon: Integer; FirstConnectedConnCompon: TObject; LastIDConnectedConnCompon: Integer; LastConnectedConnCompon: TObject; end; TTraceWithProperties = record Trace: TList; //*** ID-ки трасс Length: Double; end; TTwoID = record ID1: Integer; ID2: Integer; end; PTwoID = ^TTwoID; TOldNewID = record OldID: Integer; NewID: Integer; end; POldNewID = ^TOldNewID; TTwoObjects = record Object1: TObject; Object2: TObject; end; PTwoObjects = ^TTwoObjects; TUserReportInfo = record ID: Integer; RepKind: Integer; Name: String[255]; TemplateType: Integer; UseAsShablon: Integer; RepFileName: String[255]; end; PUserReportInfo = ^TUserReportInfo; TShowType = (st_Short, st_Full); TShowKind = (skDetail, skSimple, skExternalSCS); TStampType = (stt_simple, stt_extended, stt_detailed); TStampLang = (stl_ukr, stl_rus, stl_eng, stl_ukr_dstu); TLineType = (ltTrace, ltUpDown); TPrefixCountType = (pctBefore, pctAfter); TPointComplIndexingMode = (pcimInProject, pcimInCompon, pcimInTopCompon); TPointComonIndexingMode = (cimInProject, cimInList, cimInRoom); TReindexOrderType = (rotCreated, rotPositionPM); TAutoTraceConnectOrderType = (ctPMOrder, ctNumPanelWithNumPort); TMarkMode = (mmTemplate, mmTIAEIA606A); TRoomNameShortSrcType = (rnssRoomName, rnssRoomDefStr); TSCSTypes = set of TSCSType; TNBSettingRecord = record BuildID: Integer; DBName: String[50]; DBType: Integer; //DisableEditing: Integer; NDS: Double; BusyDate: TDate; BusyTime: TTime; BusyType: Integer; BackUpDate: TDate; UOM: Integer; end; TPMSettingRecord = record DBName: String[50]; BusyDate: TDate; BusyTime: TTime; BusyType: Integer; BackUpDate: TDate; end; TListSettingRecord = record HeightRoom: Double; HeightCeiling: Double; //*** для фальш потолка HeightSocket: Double; //*** для розеток HeightCorob: Double; //*** для коробов LengthKoef: Double; PortReserv: Double; MultiportReserv: Double; CableCanalFullnessKoef: Double; //*** % заполненности кабельного канала TwistedPairMaxLength: Double; // ограничение по максимальной длине для витой пары CADBlockStep: Double; CADClickObjectType: TClickType; CADTraceColor: TColor; CADTraceStyle: TPenStyle; CADTraceWidth: Integer; CADShowObjectNotesType: TShowType; CADStampType: TStampType; CADShowRaise: Boolean; ShowObjectTypePM: TShowType; //*** отображать полное или краткое название в МП ShowObjectTypeCAD: TShowType; //*** отображать полное или краткое название на КАДе //ShowObjectMarking: Boolean; //*** Отображать маркировки объктов GroupListObjectsByType: Boolean; //*** Группировать объекты ControlJoinByNetType: Boolean; ControlComplectByProducer: Boolean; ShowLineObjectLength: Boolean; // Отображать длину линейных объектов ShowLineObjectNote: Boolean; // Отображать подписи к линейным объектам ShowConnObjectNote: Boolean; // Отображать подписи к точечным объектам ShowLineObjectCaption: Boolean; // Отображать подписи к линейным объектам ShowConnObjectCaption: Boolean; PutCableInTrace: Boolean; // Ложить кабель на трассу NoteCountPrefix: string[1]; CADGridStep: Double; CADHeight: Double; CADPageOrient: TPageOrient; CADPageSizeIndex: Integer; CADWidth: Double; ListType: TListType; // Тип листа (обычный, отображение компоненты (Шкафа)) IDFigureForDesignList: Integer; // Связь с объектом, в котором находится Шкаф IDListForDesignList: Integer; // Связь с листом, в котором находится Шкаф //2006_02_10 ControlComplectByProperties: Boolean; ControlJoinByProperties: Boolean; //2006_05_10 CADStampLang: TStampLang; //2006_06_15 CADFontName: string[255]; //2006_07_04 CornerType: TCornerType; // Тип угла точечного объекта //20060714 KeepLineTypesRules: Boolean; //20060721 CADShowRuler: Boolean; CADShowGrid: Boolean; CADShowGuides: Boolean; CADSnapGrid: Boolean; CADSnapGuides: Boolean; CADSnapNearObject: Boolean; //2006.09.07 Temp1: Integer; CADCaptionsKind: TShowKind; // Вид отображения подписей (подробный, простой) CADNotesKind: TShowKind; // Вид отображения выносок (подробный, простой) //2006.10.25 UseComponTypeHeights: Boolean; //2006.11.14 CADShowCabinetsNumbers: Boolean; //2006.12.12 CADDimLinesType: TDimLinesType; // 2007.02.02 CADLinesCaptionsColor: Integer; // цвет подписей трасс CADConnectorsCaptionsColor: Integer; // цвет подписей коннекторов CADLinesNotesColor: Integer; // цвет выносок трасс CADConnectorsNotesColor: Integer; // цвет выносок коннекторов //2007.02.20 Temp2: Integer; CADLinesCaptionsFontSize: Integer; CADConnectorsCaptionsFontSize: Integer; CADLinesNotesFontSize: Integer; CADConnectorsNotesFontSize: Integer; //2007.02.21 CADLinesCaptionsFontBold: Boolean; CADCrossATSFontSize: Integer; CADDistribCabFontSize: Integer; CADCrossATSFontBold: Boolean; CADDistribCabFontBold: Boolean; //2007.02.22 CADPrintType: TPrintType; //2007.03.03 Temp3: integer; PrefixCountType: TPrefixCountType; //2007.03.28 SCSType: TSCSType; //2007.04.26 Temp4: integer; ShowNameInDesignList: Boolean; ShowNameShortInDesignList: Boolean; ShowNameMarkInDesignList: Boolean; //2007.05.08 CanSetCorkBetweenTraces: Boolean; //2007.05.11 CADTraceStepRotate: Integer; //2007.06.07 Temp5: Integer; AutoCadMouse: Boolean; ScaleByCursor: Boolean; CADAutoPosTraceBetweenRM: Boolean; //2007.07.25 CADListCountX: Integer; // кол-во листов данного формата по горизонтали CADListCountY: Integer; // кол-во листов данного формата по вертикали // 2007.07.31 Temp6: Integer; CADShowMainStamp: Boolean; CADShowUpperStamp: Boolean; CADShowSideStamp: Boolean; //30.10.2007 Temp7: Integer; CADSaveUndoCount: Integer; //16.01.2008 Temp8: Integer; CADAllowSuppliesKind: Boolean; //15.07.2008 CADShowCabinetsBounds: Boolean; //21.09.2010 CADRuleStep: Double; // Шаг шкалы на линейке CADRuleAllSize: Double; // Весь размер линейки //CADRuleMode //15.04.2011 CADShowPathLengthType: Byte; CADShowPathTraceLengthType: Byte; //11.11.2011 Temp9: Integer; CADStampMargins: TDoubleRect; //10.11.2011 - отступы рамки листа CADStampDeveloper: string[255]; //15.11.2011 - разработал CADStampChecker: string[255]; //15.11.2011 - проверил CADStampForPrinter: Boolean; //29.11.2011 - Была ли подгонка отступов рамки под принтер //06.08.2012 Temp10: Integer; CADGrayedColor: TColor; //06.08.2012 - Цвет прозрачности (серый) CADStampListSign: string[255]; //02.10.2012 - Обозначение док-та CADStampMainEngineer: string[255]; //02.10.2012 - Главный инженер проекта CADStampApproved: string[255]; //02.10.2012 - Утвердил CADStampDesignStage: string[255]; //02.10.2012 - Стадия проектир. Temp11: Integer; //09.10.2012 CADNewTraceLengthType: Byte; //09.10.2012 Тип длины новых трасс CADShowRaiseDrawFigure: Boolean; //28.05.2013 Отображать УГО на с-п //01.04.2014 Temp12: Integer; CableSwervesMaxCount: Integer; // макс. допустимое количество поворотов/изгибов кабеля CableSwervesAngle: integer; // макс. допустимый угол поворота кабеля // Tolik -- 16/09/2016-- ShowRaiseHeights: Boolean; AllowTransparency: Boolean; //Tolik -- 28/06/2017 -- поддерживать прозначность //ShowTracesCrossPoints: Boolean; // Tolik -- 13/09/2017 -- показывать пересечения трасс ShowTracesCrossPoints: Byte; // Tolik -- 13/09/2017 -- показывать пересечения трасс end; TProjectCurrencyInfo = record ID: Integer; Ratio: Double; end; TProjectSettingRecord = record IDCurrency: Integer; CurrencyRatio: Double; CurrensySID: Integer; CurrensySRatio: Double; NDS: Double; DefListName: String[255]; DefRoomName: String[255]; //*** Автосохранение IsAutoSaveProject: Boolean; AutoSaveProjectMinutes: Integer; AutoSaveDateTimeMinutes: Integer; //2006.03.29 CustomerName: String[255]; // Заказчик ContractorName: String[255]; // Подрядчик (исполнитель) {//2006.04.06 - значения генераторов TempField: Integer; LastGen_KatalogID: Integer; LastGen_KatalogSCSID: Integer; LastGen_CatalogRelationID: Integer; LastGen_ComponentID: Integer; LastGen_ComponentWholeID: Integer; LastGen_CatalogPropRelationID: Integer; LastGen_ComponentRelationID: Integer; LastGen_CompPropRelationID: Integer; LastGen_CableCanalConnectorsID: Integer; LastGen_ConnectedComponentsID: Integer; LastGen_InterfaceRelationID: Integer; LastGen_InterfOfInterfRelationID: Integer; LastGen_PortInterfaceRelationID: Integer; LastGen_NormsID: Integer; LastGen_NormResourceRelID: Integer; LastGen_ResourcesID: Integer; } //2006.05.15 CurrencyKolvo: Integer; CurrencySKolvo: Integer; //20060831 ListsInReverseOrder: Boolean; //2006.09.07 HeightThroughFloor: Double; //2006.10.20 Unsigned: Boolean; //2006.11.28 OrganizationName: String[255]; //2007.05.07 PointComplIndexingMode: TPointComplIndexingMode; ReindexOrderType: TReindexOrderType; GUIDNBDir: string[40]; //2007.08.06 Temp1: Integer; TraceConnectOrder: TAutoTraceConnectOrderType; TraceOnePortToOne: Boolean; TraceNoAskParams: Boolean; //2007.08.13 Temp2: Integer; UseNormsFromInterfaces: Boolean; //2008.03.14 PointComonIndexingMode: TPointComonIndexingMode; //2008.05.12 Temp3: Integer; MarkMode: TMarkMode; RoomNameShortSrcType: TRoomNameShortSrcType; RoomNameShortDefault: string[200]; RoomNameShortIfNoRoom: string[200]; IsMarkByTemplateIfNoAtOtherMode: Boolean; UnitOfMeasure: Integer; //29.10.2010 Temp4: Integer; //20.01.2014 Revision: Integer; //20.01.2014 // added by Tolik Temp5: Integer; //01.04.2014 DesignerInfo: String[255]; //проектировщик JobInfo: array [1..1000] of char; // инфо о работе CustomerInfo: array [1..1000] of char; // реквизиты заказчика ContractorInfo: array [1..1000] of char; // реквизиты подрядчика TagAdd: string[50]; FirstTraceCreated: Boolean; // Tolik -- 18/08/2021 -- первое создание трассы на проекте (по просьбе РОМЫ) end; PProjectSettingRecord = ^TProjectSettingRecord; TProjectGenerators = record LastGen_KatalogID: Integer; LastGen_KatalogSCSID: Integer; LastGen_CatalogRelationID: Integer; LastGen_ComponentID: Integer; LastGen_ComponentWholeID: Integer; LastGen_CatalogPropRelationID: Integer; LastGen_ComponentRelationID: Integer; LastGen_CompPropRelationID: Integer; LastGen_CableCanalConnectorsID: Integer; LastGen_ConnectedComponentsID: Integer; LastGen_InterfaceRelationID: Integer; LastGen_InterfOfInterfRelationID: Integer; LastGen_PortInterfaceRelationID: Integer; LastGen_NormsID: Integer; LastGen_NormResourceRelID: Integer; LastGen_ResourcesID: Integer; LastGen_CADNormStructID: Integer; LastGen_CADNormColumnID: Integer; LastGen_InterfPosConnection: Integer; LastGen_CADCrossObject: Integer; LastGen_CADCrossObjectElement: Integer; LastGen_StringID: Integer; LastGen_FilterInfoID: Integer; LastGen_ObjectsBlobs: Integer; end; TRoomSettingRecord = record HeightCeiling: Double; end; PRoomSettingRecord = ^TRoomSettingRecord; TObjectParams = record ID: Integer; Name: String[255]; NameShort: String[200]; Caption: String[255]; MarkID: Integer; HeightCeiling: Double; IndexWithName: Integer; CabinetConfig: TRoomConfig; end; PObjectParams = ^TObjectParams; TFigureIconParams = record GUIDObjectIcon: string[cnstGUIDLength]; IconType: Integer; IconCount: Integer; end; TListParams = record ID: integer; Caption: String; Name: String; MarkID: Integer; // Index IsIndexWithName: ShortInt; IndexPointObj: Integer; IndexConnector: Integer; IndexLine: Integer; Settings: TListSettingRecord; end; PListParams = ^TListParams; TProjectParams = record ID: Integer; Caption: String; Name: String; MarkID: Integer; // Index IsIndexWithName: ShortInt; Setting: TProjectSettingRecord; DefListSetting: TListSettingRecord; ServRemarkAllCompons: Boolean; ServCreateList: Boolean; ServCanRecalcPricesByNDSChange: Boolean; end; TObjectIconInfo = record ID: Integer; GUID: String[cnstGUIDLength]; Name: String[255]; ProjBlk: TStream; ProjBmp: TStream; ActiveBlk: TStream; ActiveBmp: TStream; end; PObjectIconInfo = ^TObjectIconInfo; TObjectIconData = record IDCatalog: Integer; CatalogItemType: Integer; ID: Integer; GUID: Integer; Name: String[255]; //ProjBlk: String[40]; //ProjBmp: String[40]; //ActiveBlk: String[40]; //ActiveBmp: String[40]; ProjBlk: Integer; ProjBmp: Integer; ActiveBlk: Integer; ActiveBmp: Integer; end; TObjectIconParams = record IDIcon: Integer; GUIDIcon: string[cnstGUIDLength]; IconBLK: TMemoryStream; IconBMP: TBitmap; Executed: Boolean; end; TComponDesignWizardParams = record GUIDDesignIcon: string[cnstGUIDLength]; IDDesignIcon: Integer; ObjectSignType: Integer; Height: Double; Width: Double; BottomBound: Double; LeftBound: Double; RightBound: Double; TopBound: Double; end; TTablesID = record IDComponent: Integer; IDCompRel: Integer; IDInterfRel: Integer; IDInterfOfInterfRel: Integer; IDCompPropRel: Integer; end; PTablesID = ^TTablesID; TIDPointerInfo = record FieldName: String[200]; IDValue: Integer; GUIDValue: String[40]; end; PIDPointerInfo = ^TIDPointerInfo; TCostOfProjectReportParams = record ZakazchikName: string[255]; PodradchikName: string[255]; CurrencyName: string[50]; end; //*** Результаты обновлений нормативной базы TUpdateBaseResult = (ubrSuccessful, ubrTrgBaseNotExist, ubrSrcBaseNotExist, ubrTrgBaseOpenError, ubrSrcBaseOpenError, ubrSameBases, ubrSrcIsNoNB, ubrSrcIsNoProperRequired ); TUpdateBaseResults = set of TUpdateBaseResult; TUpdateNodeResult = (unrNew, unrUpdate, unrGoToExistsObject, unrCancel, unrNoExistsRecord); TUpdateBaseMode = (ubmUpdate, ubmLoadData); TUpdateBaseParams = record RequiredDBTypes: TIntSet; DestObjectGUID: String[cnstGUIDLength]; SrcDBType: Integer; SrcObjectGUID: String[cnstGUIDLength]; SrcObjectID: Integer; SrcTableName: String[cnstGUIDLength]; UpdateBaseMode: TUpdateBaseMode; UpdateNodeResult: TUpdateNodeResult; end; TTraceInfo = record FigureID: Integer; Position: TTraceTypePorition; HeightSide1: Double; HeightSide2: Double; IsSelected: Boolean; end; PTraceInfo = ^TTraceInfo; TPointFigureSearchInfo = record Distance: Double; ComplexObject: TObject; RelatedLine: TObject; IsLooked: Boolean; OrderCount: Integer; FPointFiguresRels: TRapList; // List of TPointFigureRelation sorted by other object id FPointFiguresRelsID: TRapList; // other object id for FPointFiguresRels end; PPointFigureSearchInfo = ^TPointFigureSearchInfo; TLineFigureSearchInfo = record IsLocked: Boolean; OrderCount: Integer; end; PLineFigureSearchInfo = ^TLineFigureSearchInfo; //*** Net Tools TShareInfo2 = packed record shi2_netname : PWChar; shi2_type: DWORD; shi2_remark :PWChar; shi2_permissions: DWORD; shi2_max_uses : DWORD; shi2_current_uses : DWORD; shi2_path : PWChar; shi2_passwd : PWChar; end; PShareInfo2 = ^ TShareInfo2; TShareInfo2Array = array [0..512] of TShareInfo2; PShareInfo2Array = ^ TShareInfo2Array; TShareInfo50 = packed record shi50_netname : array [0..12] of Char; shi50_type : Byte; shi50_flags : Word; shi50_remark : PChar; shi50_path : PChar; shi50_rw_password : array [0..8] of Char; shi50_ro_password : array [0..8] of Char; end; TShareInfo298 = packed record shi2_netname : array[0..12] of Char; shi2_type: Byte; shi2_remark : PChar; shi2_max_uses : DWORD; shi2_current_uses : DWORD; shi2_path : PChar; shi2_passwd : array[0..9] of Char; end; TSERVER_INFO_100 = record sv100_platform_id: DWORD; sv100_name: LPTSTR; end; TInternationalSettings = record DecimalSeparator: string[1]; DateSeparator: string[1]; ShortDateFormat: String[50]; ThousandSeparator: string[1]; end; TAreaCornerType = (ctTopLeft, ctTopMiddle, ctTopRight, ctRightMiddle, ctBottomRight, ctBottomMiddle, ctBottomLeft, ctLeftMiddle, ctMiddle); function _ltoa (Value: Integer; Buffer: PChar; Radix: Integer): PChar; cdecl; external 'ntdll.dll' name '_ltoa'; //*** Матем. ф-ции function ABCToDec(AStrValue: String): Integer; function ConvertUOMToMin(AUOM: Integer): Integer; function ConvertUOMToSuppliesKind(AUOM: Integer): Integer; procedure GetMetricSettings; // Привести Float значение к другой единици измерения function FloatInUOM(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1): Double; // перевод из м в футы - для правильного перевода используется уточненное значение коэф. function FloatInUOMSpec(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1): Double; function FloatInUOMStr(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1; AUOMCaption: Boolean=false): String; procedure PropValueInUOM(var AValue: Double; const ASysName: string; ACurrUOM, AResUOM: Integer); // Tolik Function CheckSysNameInUOM(const ASysName: string): Boolean; // function PropValueToCaption(const AValue, ASysName, AIzm: string; AIDDataType, AUOM: Integer; AAllowIzm: Boolean): string; function PropValToStr(AProp: PProperty): String; // Преобразует из десятичной системы числения в алфавитный порядковый function DecToABC(ADecValue: Integer): string; // Преобразует из десятичной системы числения в другую function DecToSN(ADecValue, ASN: Integer): TIntList; function RoundX(Num: Extended; Dig: integer): Extended; stdcall; function Round0(N: Extended): Extended; stdcall; function Round2(N: Extended): Extended; stdcall; function Round3(N: Extended): Extended; stdcall; function Round4(N: Extended): Extended; stdcall; function RoundCP(N: Extended): Extended; stdcall; //CP - Current Precision function RoundUp(N: Extended): Integer; procedure SaveGlobalInternationalSettings; procedure SetCursors; procedure SetInternationalSettingsToRegistry(ASettings: TInternationalSettings); procedure SetLocaleInternationalSettings; function StrToDateS(AString: string): TDate; function DateToStrU(const DateTime: TDateTime): string; function DateTimeToStrU(const DateTime: TDateTime): string; // Вернет не нулевое значение function FloatNoZero(AValue, ANoZeroVal: Double): Double; function FloatToStrU(Value: Extended): string; function FloatToStrFU(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string; function FormatFloatU(AFormat: String; AFloat: Extended): String; //function IntToStrU(Value: Integer): string; function StrToDateU(const S: String): TDateTime; function StrToFloatU(const S: String): Extended; function StrToFloatDefU(const S: string; const Default: Extended): Extended; function StrToMinLen(const aStr: String; aMinLen: Integer): String; //function StrToIntU(const S: string): Integer; function HmsStr(const aSepartor: string=''): string; function YMDStr(const aSepartor: string=''): String; procedure EmptyProcedure; function AddGUIDIDToStrings(const AName, AGUID: String; AID: integer; AStrings: TStrings; AIndex: Integer = -1): TObject; procedure AddGUIDIDToStringsFromMT(AStrings: TStrings; AMemTable: TkbmMemTable; const ANameFld, AGUIDFld: String; AClear: Boolean=true); function IndexOfGUIDInStrings(const AGUID: String; AStrings: TStrings): Integer; function GetGUIDFromStrings(AStrings: TStrings; AIndex: Integer): String; overload; function GetGUIDFromStrings(AStrings: TStrings; const AName: String): String; overload; function GetIDFromStrings(AStrings: TStrings; AIndex: Integer): Integer; function GetNameFromStringsByGUID(const AGUID: String; AStrings: TStrings): String; procedure RemoveGUIDIDFromStrings(AStrings: TStrings; ACanClear: Boolean=false); function CreateGUID: String; procedure CorrectMaskKeyPress(var Key: Char); function CorrectStrToCSV(AStr: String): String; function CorrectStrToFloat(const AStr: String): String; function IsEmptyVal(AVal: String): Boolean; function StrCanBeFloat(AStr: String): Boolean; function StrAsEmptyToFloat(AStr: String): Double; function GetDimensionsMask: String; function GetDisplayFormat(const NameBrief: String): String; function GetDisplayFormatForFloat: String; function GetDisplayFormatForFloatByPrecision(APrecision: Integer): String; function GetFloatMask(aPrecision: Integer=2): String; function GetFloatMaskUnsig(aPrecision: Integer=2): String; function GetZeroConditionAsNull(AFieldName: String; ACondition: Integer): String; function GetPrefixCountByType(const AText, APrefix: String; ACount: Integer; APrefixType: TPrefixCountType): String; function GetStringsFromStr(const AStr: string; ASeparator: Char; AIncludeEmptySections: Boolean): TStringList; function SplitString(const AStr, ASeparator: string; AIncludeEmptySections: Boolean): TStringList; function ConcatStrWithDefis(AStr1, AStr2: String; ASpaces: Integer = 0): String; function RemoveNoAssignedStrings(ADestStringList, AStringsToCmp: TStringList): Boolean; procedure SetGUIDToStrings(AStrings: TStrings; const AGUID, AName: String); function CheckFileInUse(FileName: String): Boolean; function CompareFiles(Filename1,FileName2:string): Boolean; function CompareFilesStrings(AFileName1, AFileName2: string): Boolean; function CheckIsIPName(AName: string): Boolean; function CopyFileToByName(ASrcDBName, ANewDBName: String): Boolean; function GetCharCountFromStr(AChar: Char; AStr: String): Integer; function GetFileOwner(FileName: string; var Domain, Username: string): Boolean; function BrowseDialog(const aTitle, ADefFolder: string; const aFlag: integer = BIF_RETURNONLYFSDIRS): string; function IsNT(var Value: Boolean): Boolean; function GetLocalPath(Server: string; NetDrive: string): string; function GetFullRemotePath(APath: String): String; function BrowseDialogRemote(AHandle: THandle; ADefFolder, ATitle: String): String; function FilePathToURL(const AUrl: string): string; function FindComputers(xxx: PNetResource;AStringList: TStringList=nil): TStringList; procedure OpenURL(const AURL: String); function ShowServerDialog(AHandle: THandle): string; //function BrowseNewDirName(aTitle, aDirPath, aDefNewDirName: string): string; function BrowseComputer(ADialogTitle: String=''; ADefComputer: string=''; bNewStyle: boolean=false): String; function AddCreateDirToPath(const APath, ADirName: string): String; function CheckIsLicalPath(const APath: string): Boolean; // Tolik -- 31/07/2019 -- function CheckStrInFilePos(AFileName, AString: String; AFilePos: Integer): Boolean; // function CheckOneStrInFilePos(AFileName: String; AStringList: TStringList; AFilePos: Integer): Boolean; function ConverPathToNix(APath: String): String; function DefineDir(const APath: String): Boolean; function ExpandPath(const Path: string): string; function ExtractDefDirByCategoryType(ADirCategoryType: Integer): string; function ExtractDirByCategoryType(ADirCategoryType: Integer): string; function ExtractDirByCategoryTypeDefault(ADirCategoryType: Integer): string; function ExtractDirName(const APath: String): String; function ExtractFileNameOnly(const AFileName: String): String; function ExtractFilePathOnly(const AFileName: String): String; function ExtractFirstDirName(APath: String): String; function ExtractMyDocDir: String; function ExtractSaveDirForCategory(const ACategoryName: string): string; function ExtractSaveDirSimple: String; function ExtractSaveDir(AProjDirName: string = ''): String; function ExtractSaveProjectsDir: string; function ExtractSaveSettingsDir: string; procedure ExtractServerName(const AFileName: String; var AServerName, ALocalPath: String); function ExtractSCSTempDir: String; function FileNameCorrect(AFileName: string): string; function GetAnsiTempPath: String; function GetDefaultTempPath: String; function GetFileContents(const aFilePath: String): String; function GetFileFullPathTmp(const AFilePath: string): String; function GetFileSizeByName(AFileName: String): Integer; function GetUniqueFileName(const APrefix, AExtension: String): String; function GetDialogFilter(const AExtensionDescription, AExtension: String): String; function GetExtensionDescription(const AExt: String): String; function GetPCharLength(APChar: PChar): Integer; function GetFullFilePath(InputName: string): string; function GetShortFilePath(const FileName: string): string; function CutBeginZeroDefisInArticle(const AArtNo: String): String; function CmpFloatByPrecision(AVal1, AVal2: Double; APrecision: Integer): Boolean; function CmpFloatByCP(AVal1, AVal2: Double): Boolean; function CmpRecords(AAddrRec1, AAddrRec2, ASize1, ASize2: Integer): Boolean; function CompareInt(const AVal1, aVal2: Integer): Integer; function GetDeltaOneByPrecision(APrecision: Integer): Double; function IntToBool(AInt: Integer): Boolean; function BoolToInt(ABool: Boolean): Integer; function BoolToStrL(ABool: Boolean): String; function GetItemTypeName(AItemType: TItemType): String; function ItemTypeToIsOwnerFieldName(AItemType: TItemType): String; function Int2Str(Data: integer; Radix: integer = 2): string; function IntToStrF(AInt: Integer; AMinLen: Integer): String; function FloatToStrFix(AValue: Double; APrec: Integer): String; // Форматирует Float в строку с нужным количеством символом после //function FloatToStrPrec(AValue: Double; APrec: Integer): String; function IsTreeViewItemTypesOfCommonKind(AItemType1, AItemType2: Integer): Boolean; function DupStr(AStr: String; ADupKol: Integer): String; function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer; function SubstrMatches(const SubStr, S: string): Integer; function FormatShifrToShortDBN(S: String): String; // Проверяет строки на общий параметр (параметры разделены символом ";") function CheckStrForCommonParam(const AStr1, AStr2: string): Boolean; function CheckStrHaveRusSymb(const AStr: String): Boolean; function CheckStringsHaveRusSymb(AStrings: TStrings): Boolean; // Есть ли общие строки в списках function CheckStringsHaveSameItems(AStrings1, AStrings2: TStrings): Boolean; // Проверяет, входит ли строка в список строк, заданый текстом function CheckStrInStringsText(const AStrValue, AStringsText: String): Boolean; function GetStrCheckSum(const AStr: String): Integer; function GetMethodName(const AClass, AMethod: string): string; function RemoveSymbolFromStr(AStr: String; ASymb: Char): string; function StringReverse(const AStr: String): String; function CustMessageDlg(ARus, AUkr: String): TModalResult; procedure ActionCaptionsToHints(AActionList: TActionList); procedure AddToExecuteLog_(AString: String; APos: Integer = -1); procedure AddExceptionToLog(const AText: String; AShowText: Boolean = false); procedure AddExceptionToLogEx(const AProcedureName, AException: String; AShowText: Boolean = false); procedure AddExceptionToLogExt(const AClass, AMethod, AException: String; AShowText: Boolean = false); // Tolik -- 30/12/2015 procedure AddExceptionToLogSilent(const AText: String); // function ComparePropValues(const AVal, ACmpVal: String; ADataType: Integer; ACompareType: Integer): Boolean; function ExistsModalForm: Boolean; function GetAveCharSize(Canvas: TCanvas): TPoint; function MessageDlgLn(const AMsg, ACaption: string; ADlgType: TMsgDlgType; AButtons: TMsgDlgButtons): Word; function MessageModal(const AText, ACaption: String; AStyle: Uint): Integer; procedure MessageError(const AText: string); procedure MessageInfo(const AText: string); function MessageQuastYN(const AText: string): Integer; function MessageQuastYNC(const AText: string): Integer; function InputForm(AForm: TForm; ACaption, APrompt, ADefault: Variant; ADataType: Integer = dtString): Variant; function InputPassQuery(const ACaption, APrompt: string; var Value: string): Boolean; //30.10.2012 - взято из InputQuery // Заполняет TStrings типами сравнения по типу свойства function FillPropCompareTypesByDataType(AStrings: TStrings; ADataType: Integer): Integer; // Заполняет TStrings значениями по типу свойства procedure FillPropValuesByDataType(AStrings: TStrings; ADataType: Integer); function GetMasterTracingCaption(const AComponentTypeSysName: String): String; function GetCaptionNormsResourcesTotalKolvo(AUOM: Integer; ALength: Double): String; function GetDisplayTextInFLoatUOMMin2(ATextValue: String; AUOM: Integer): String; function GetDisplayTextInFLoatUOM(ATextValue: String; AUOM: Integer): String; function GetDisplayTextToNORMExpenseForLength(const ATextValue: String; AUOM: Integer): String; function GetDisplayTextToNORMLaborTime(const ATextValue: String; aShowDays: Boolean = false): String; function GetFileNameToSaveProtocol: String; function GetNoExistsFileNameForCopy(const AFileName: String): String; function GetPropStrValueByDisplay(const ADisplayText, ASysName: String; ADataType, AUOM: Integer): String; function HitTestCloseControl(AControl: TControl; AMousePoint: TPoint): Boolean; procedure OnNormsResourcesCustomDrawCell(ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo; AIsResourceIndex, AGUIDNBComponIndex, ATotalKolvoIndex: Integer; AHaveNorms: Boolean); procedure SaveProtocolToFile(AFileName: String); procedure ShowMessageByType(AHandle: HWND; AShowMessageType: TShowMessageType; AText, ACaption: String; AStyle: uint); procedure ShowError(AProcName, AMessage: String); procedure ShowExcept(AMessage: String); procedure SetFromActualSize(AForm: TForm); procedure SetMiddleControlPos(AControl: TControl); procedure SetMiddleControlChilds(AControl, AMainControl: TControl); procedure SetDisplayTextToGridTablePropIzm(var AText: string; ARecord: TcxCustomGridRecord; ASysNameIndex, AUOM: Integer); procedure SetDisplayTextToGridTablePropValue(var AText: string; ARecord: TcxCustomGridRecord; ADataTypeIndex, ASysNameIndex, AUOM: Integer); procedure SetVisibleGridLevel(ALevel: TcxGridLevel; ATabControl: TRzTabControl; AVisible: Boolean); procedure ShowPopupMenuForControl(AButton: TControl; APopupMenu: TPopupMenu); procedure EnableControl(AControl: TWinControl; AEnable: Boolean); procedure LockControl(AControl: TWinControl; ALock: Boolean); procedure SetFocusToControl(AControl: TWinControl); procedure SetCableChannelSectionMaskEditProps(AMaskEditProps: TcxMaskEditProperties); procedure SetCheckToMenuItemList(AMenuItems: TList; ATagToCheck: Integer); procedure SetStyleToRZDateTimeEdit(ARzDateTimeEdit: TRzDateTimeEdit); procedure SetStyleToRZColorEdit(AColorEdit: TRzColorEdit); procedure ShowHideMenuItems(AMenu: TMenu; AShow: Boolean; AllowAction: Boolean=true); procedure ShowHideMenuItemsList(AMenuItems: TList; AShow: Boolean; AllowAction: Boolean=true); procedure ShowHidePageControlTabls(APageControl: TRzPageControl; AShow: Boolean; APagesToSkip: TList=nil); procedure ShowHintES(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); procedure ShowHintImg(const aImgPath: String; aHideTimeout: Integer; aPoint: PPoint=nil); procedure ShowHintInCursorPos(const AText: String; ATimeInterval: Integer); procedure ShowHintRz(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); procedure ShowHintRzR(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); procedure HideHintES; procedure HideHintImg; procedure HideHintRz; procedure HideHintInCursorPos; function IsVisibleHintES: Boolean; procedure ValidateActiveFormControl(AForm: TForm); procedure EnableTimerWithOrder(ATimer: TTimer; AEnable: Boolean; AHightPriority: Boolean = false); function IsOtherTimerToHandleInOrder(ATimer: TTimer): Boolean; procedure RestartTimer(ATimer: TTimer); procedure TerminateApplicationWithMessage(AMessage: String); function GetComputerNetName: string; function GetIPAddress: String; function GetIPAddressFromName(AName: string): String; //function GetTFormByChildObj(AChildObj: TObject): TObject; procedure GetZeroMem(var P; ASize: Integer); procedure NewData(var AObjectData: PObjectData; ATreeType: TTreeType); function GetMakeEditByFormMode(AFormMode: TFormMode): TMakeEdit; procedure AddStringToStringListOnce(AStringList: TStringList; const AString: String); function CreateStringListSorted: TStringList; Procedure CutColFromStr(Var AStr: String); function FindCypherTytleAtStringList(AStringList: TStringList; AAllCypher: String; var ATytle: String): Boolean; procedure AddRecordToListAsSorted(AList: TList; ARecPointer: Pointer; ASortFldOffset: Integer); procedure ClearAndDisposeList(AList: Tlist); procedure FreeAndDisposeList(AList: Tlist); procedure FreeList(AList: Tlist); procedure ClearList(AList : TList); //Tolik 24/07/2018 -- Procedure FreeObjectList(aList: TList); // function CheckEqualIntLists(AList1, AList2: TIntList): Boolean; procedure AssignListItems(ASrcList, ATrgList: TList); procedure RemoveFromListItems(ADstList, AListItemsToRemove: TList); function CheckNoIDinList(ACheckID: Integer; AList: TList): Boolean; function RemoveFromStringList(AStringList: TStringList; const AString: String): Integer; function CheckInterfForUnion(AInterf1, Ainterf2: TObject; AInterf1Form, AInterf2Form: TForm; {AConnectKinds: TConnectKind;} AConnectType: TConnectType; AKolvoInterf1, AKolvoInterf2: PInteger; ASkipElements: TCheckInterfForUnionElements=[]): TCheckInterfForUnionResult; function CheckInterfAccordInList(AList: TList; AIDInterf1, AIDInterf2, AIsLine1, AIsLine2: Integer): Boolean; //procedure RemoveInterfFromAllReferences(AInterface: TObject); procedure Delay(AmkSeconds: Integer); procedure ScrollTreeOnDrag(ATreeView: TTreeView; AX, AY: Integer; AScrollSleep: Integer = 40); procedure ScrollTreeOnDragByRect(AForm: TForm; ATreeView: TTreeView); function WaitBeforeDragExpand(AmkSecond: Integer; ATargetNode: TTreeNode): Boolean; function ExpandCursorNodeByTimer(AForm: TForm; ATreeView: TTreeView; AFirstCursorNode: TTreeNode; ATimerInterval: Integer): Boolean; procedure HandleTimerExpandNode; procedure HandleTimerTreeViewScrolling; function AddNodeToTreeViewFly(ATreeView: TFlyTreeViewPro; AParentNode: TFlyNode; const ACaption: String; AImageIndex, AStateIndex: Integer; AData: Pointer): TFlyNode; function CheckNodeHaveParent(aNode, aParent: TTreeNode): Boolean; function CheckNodesSameParentFly(ANodes: TList): Boolean; function CheckSelectedNodesHaveSameParentFly(ATreeView: TFlyTreeViewPro): Boolean; procedure ClearTreeView(ATreeView: TTreeView; AFreeNodeData: Boolean = true; ALockEvents: Boolean = false); procedure ClearTreeViewFly(ATreeView: TCustomRapidTree; AFreeNodeData: Boolean = true; ALockEvents: Boolean = false; ADataIsObject: Boolean = false); procedure CopyChildNodesFromList(ATreeView: TTreeView; AParentNode: TTreeNode; ASrcNodes: TObjectList); procedure DeleteNode(ANode: TTreeNode); procedure DeleteChildNodes(ANode: TTreeNode); procedure ExchangeSiblingNodes(ANode1, ANode2: TTreeNode); procedure ExchangeSiblingNodesFly(ANode1, ANode2: TFlyNode); procedure ExchangeTreesNodesFly(ATreeView1, ATreeView2: TFlyTreeViewPro; AOnAfterSetNodeData: TNotifyEvent); function GetAllChildNodes(ANode: TTreeNode; aSelected: Integer=biNone): TObjectList; function GetAllChildNodesFly(ANode: TFlyNode): TObjectList; function GetComponKindByItemType(AItemType: Integer): TComponKind; function GetFirstNodeFromFlyTree(AFlyTreeView: TCustomRapidTree): TFlyNode; function GetTreeViewDataListFly(ATreeView: TFlyTreeViewPro): TList; function GetTreeViewNodeByData(ATreeView: TTreeView; AData: Pointer; ASelectFinded: Boolean): TTreeNode; function GetTreeViewNodeByDataFly(ATreeView: TFlyTreeViewPro; AData: Pointer; ASelectFinded: Boolean): TFlyNode; function GetTreeViewNodeByPathFly(ATreeView: TFlyTreeViewPro; const APath, ASeparator: String): TFlyNode; function GetTreeViewNodePathFly(ANode: TFlyNode; const ASeparator: String): String; function GetTreeViewNodesFly(ATree: TCustomRapidTree): TList; function GetTreeViewFirstSiblingNode(ANode: TTreeNode): TTreeNode; function GetTreeViewFirstSiblingNodeFly(ANode: TFlyNode): TFlyNode; function GetTreeViewFirstTopNode(ANode: TTreeNode): TTreeNode; function GetTreeViewFirstTopNodeFly(ANode: TFlyNode): TFlyNode; function GetTreeViewSelectedNodeInComboOnClose(ATreeView: TFlyTreeViewPro; ADropDown: TISDropDown): TFlyNode; function GetTreeViewSelectedNodesFly(ATreeView: TFlyTreeViewPro): TList; function GetTreeViewSelectedNodesCountFly(ATreeView: TFlyTreeViewPro): Integer; function IsGraphModTemplate(ATemplateType: Integer): Boolean; function IsCatalogItemType(AItemType: Integer): Boolean; function IsCatalogItemTypeForCompon(AItemType: Integer): Boolean; function IsComponItemType(AItemType: Integer): Boolean; function IsTemplateImageIndex(AItemType: Integer): Boolean; function IsComponentNode(ANode: TTreeNode): Boolean; function IsHiddenNodeByParantFly(ANode: TFlyNode): Boolean; function IsGroupObjectNode(ANode: TTreeNode): Boolean; function IsImageIndexShowConnectCompon(AImageIndex: Integer): Boolean; function IsSCSGroupItemType(AItemType: Integer): Boolean; function IsSCSObjectItemType(AItemType: Integer): Boolean; procedure ReloadTreeView(ATreeView: TTreeView); function ReplaceTextInStr(const ASrch, AReplace, AText: String; AWholeWord: Boolean; AWasReplace: PBoolean): String; procedure ReplaceTextInStringList(ASrch, AReplace: String; AStringList: TStringList; AWholeWord: Boolean); procedure SelectTreeViewNodesFly(ATreeView: TFlyTreeViewPro; ANodesToSelect: TList; ASelected: Boolean); procedure SortComplexStringList(AMainStringList, ASecondStringList: TStringList); procedure SortStrings(AStrings: TStrings); procedure SortTreeViewChildNodes(AParentNode: TTreeNode; ATreeView: TTreeView; ASortType: TTreeSortType; AReverse: Boolean = false); procedure SortTreeViewChildNodesFly(AParentNode: TFlyNode; ATreeView: TFlyTreeViewPro; ASortType: TTreeSortType; AReverse: Boolean = false); procedure CheckUnCheckListViewItems(AListView: TListView; ACheck: Boolean); procedure ClearListView(AListView: TListView); procedure ClearListViewRz(AListView: TRzListView); procedure ClearListViewObjects(AListItems: TListItems); procedure BuildTree(AForm: TForm; ATreeType: TTreeType); procedure ExpandTree(AForm: TForm; ATreeType: TTreeType); procedure ExpandChildNodes(ANode: TTreeNode); procedure ExpandChildNodesFly(ANode: TFlyNode); procedure CollapseNode(ANode: TTreeNode; ARecurse: Boolean); procedure CollapseNodeFly(ANode: TFlyNode; ARecurse: Boolean); procedure ExpandNode(ANode: TTreeNode; ARecurse: Boolean); procedure ExpandNodeFly(ANode: TFlyNode; ARecurse: Boolean); procedure CollapseTree(AForm: TForm; ATreeType: TTreeType); function HaveNodeSub(ANode, ASub: TTreeNode): Boolean; function HaveNodeSubByPObjectData(ANode, ASub: TTreeNode): Boolean; procedure ClearTree(ATreeView: TTreeView); // может компонента в НБ иметь подключения function IsCanNBComponNodeHaveConnection(ANode: TTreeNode): Boolean; function GetParentNodeByLevelFly(ANode: TFlyNode; ALevel: Integer): TFlyNode; procedure MakeNodeVisible(ANode: TTreeNode); procedure SelectNodeFly(ATreeView: TFlyTreeViewPro; ANode: TFlyNode); procedure ShowNode(ATreeView: TTreeView; ANode: TTreeNode); procedure ShowNodeFly(ATreeView: TFlyTreeViewPro; ANode: TFlyNode); procedure ShowSelectedNode(ATreeView: TTreeView; aShowNode: Boolean = True); procedure ShowSelectedNodeFly(ATreeView: TFlyTreeViewPro); procedure SetTreeNodesToCheckTreeViewRz(ATreeView: TRzCheckTree; ATreeNodes: TTreeNodes); function GetTargetNodeForNewList(var AMayOpenProject: Boolean): TTreeNode; procedure FindGroupNodes(AListNode: TTreeNode; var ALineGroupNode: TTreeNode; var AConnGroupNode: TTreeNode); function GetQueryModeByGDBMode(AGDBMode: TDBKind): TQueryMode; function GetQueryModeByParentNode(AGDBMode: TDBKind; AParentNode: TTreeNode; ADefQueryMode: TQueryMode): TQueryMode; function GetQueryModeByNode(AGDBMode: TDBKind; AParentNode: TTreeNode; ADefQueryMode: TQueryMode): TQueryMode; procedure ClearcxImage(AImage: TcxImage); function GetSelectedIDsFromCXTableView(ATableView: TcxGridDBTableView): TIntList; function GetComponImageIndexByFilling(AIsLineComponent: Integer; AFilling: TFillConnectConObj; AAsConnected: Boolean = false): Integer; function GetImageIndexNoConnected(AImageIndex: Integer): Integer; function GetInterfaceImageIndesByIsBusy(AIsBusy: Integer): Integer; function GetRadioGrpBoxIntVal(const aObjs: array of TObject; const aVals: array of Integer; aDefVal: Integer): Integer; procedure InitDynArrayOfObject(var aTrgArray: TObjectArray; const aArray: array of TObject); procedure InitDynArrayOfInt(var aTrgArray: TIntegerArray; const aArray: array of Integer); procedure loadObjectIconToCXImage(AImage: TcxImage; AIDIcon, AObjectIconType: Integer; ADBMode: TDBKind = bkNormBase); function LoadInterfPositionsToMenuItem(AMenuItem: TMenuItem; AInterface: TObject; AOnClick: TNotifyEvent): Boolean; procedure SetCxCurrencyEditProperties(aProps: TcxCustomEditProperties); procedure SetCheckBoxStyleByVal(const aObj: TObject; aVal: Boolean); procedure SetRadioGrpBoxIntVal(const aObjs: array of TObject; const aVals: array of Integer; aVal: Integer; aWithoutEvent:Boolean=false); procedure SetRadioGrpBoxStyleByIntVal(const aObjs: array of TObject; const aVals: array of Integer; aVal: Integer); procedure SetValueToCXRadioBottonAsNoChange(ARadioButton: TcxRadioButton; AValue: Boolean); procedure SetValueToCXTextEditAsNoChange(ATextEdit: TcxTextEdit; const AValue: String); procedure SetValueToRzRadioButtonAsNoChange(ARadioButton: TRZRadioButton; AValue: Boolean); procedure ShowPathByInterfPosition(AObject{, AInterf, AInterfPos}: TObject); procedure BitmapToNormalSize(ABitmap: TBitmap; AMaxSideSize: Integer); procedure StretchBitmap(ABitmap: TBitmap; AHeight, AWidth: Integer); function CheckInterfIsUse(AFormBase: TForm; AIDComponent, AIDInterfRel, ANumPair: Integer): Boolean; function IsUseInterfRelInMemTable(AFormBase: TForm; AMemTable_Interf: TkbmMemTable; AMakeEdit: TMakeEdit; AShowMessage: Boolean): Boolean; function IsUseInterfRelInPortInterfRels(AInterfRelMemTable, APortInterfRelMemTable: TkbmMemTable; AMakeEdit: TMakeEdit; AShowMessage: Boolean): Boolean; // Tolik --14/06/2016 -- //function GetInterfaceNormInfo(AInterface: TObject): TList; function GetInterfaceNormInfo(AInterface: TObject): TList; overload; function GetInterfaceNormInfo(AInterface: TObject; GetFirstCableTracing: boolean): TList; overload; //function GetInterfaceNormInfo(AInterface: TObject; GetFirstCableTracing: boolean): TList; overload; // function GetInterfaceGenderName(AGenderIndex: String): String; function GetInterfGenderInverse(AGender: Integer): Integer; procedure ShowMessageAboutCheckCableCanalElemnts(const AComponentName: String; AElementsCount: Integer); procedure ShowSpravochnikForInterface(AForm: TForm; AMemTable: TkbmMemTable); procedure BaseBeginUpdate; procedure BaseEndUpdate; procedure BeginDevideLine; procedure EndDevideLine; procedure BeginDublicateCADObjects; procedure EndDublicateCADObjects; procedure BeginAutoTrace; procedure EndAutoTrace; procedure RefreshPMLockedTree; procedure DisableMarking; procedure EnableMarking; function CheckPropSysNameInUOM(const ASysName: String): Boolean; function CheckSysNameIsCable(const ASysName: string): Boolean; function CheckSysNameIsCableChannel(const ASysName: string): Boolean; function CheckSysNameIsTrunk(const ASysName: string): Boolean; procedure ChangeCurrList(var AIDCurrList: Integer; ANewIDCurrList: Integer); procedure ChangeCurrProject(var AIDCurrProject: Integer; ANewIDCurrProject: Integer); function CheckIsOpenProject(AMessage: Boolean): Boolean; function CheckIsOpenProjectBeforeOperation(AMessage: Boolean): Boolean; function CheckIsOpenListBeforeOperation(ACheckNormal, AMessage: Boolean): Boolean; function GenCurrProjTableID(AGeneratorIndex: Integer; AIncrement: Integer = 1): Integer; function GenNewSCSID: Integer; function GenNewListID: Integer; function GenNewSCSObjectID: Integer; function GenObjectNewIndex(AObject: TObject; ASCSObjectKind: TSCSObjectKind): Integer; function GenNewComponentCypher(AQuery1, AQuery2: TpFIBQuery): String; function GenNewComponentWholeID: Integer; function GenNewCompRelSortID(AForm: TForm; AIDParentComponent: integer): Integer; procedure AddStrToMemTable(AMemTable: TkbmMemTable; AFieldName, AStr: String); procedure AssignDataSetRecord(AMakeEdit: TMakeEdit; ATrg, ASrc: TDataSet; const AFieldsToSkip: String); procedure AssignDataSetRecordFromFIBQuery(AMakeEdit: TMakeEdit; ATrg: TDataSet; ASrc: TpFIBQuery); procedure AssignMemTable(ATrg, ASrc: TkbmMemTable; AActivateTrg: Boolean); procedure ClearFieldsInMemTable(AMemTable, ADetailMemTable: TkbmMemTable); // Подключает DetailMemTable procedure ConnectDetailMemTable(AMasterSource: TDataSource; ADetailMemTable: TkbmMemTable; const AMasterField, ADetailField: String); // Отключает DetailMemTable procedure DisconnectDetailMemTable(AMemTable: TkbmMemTable); procedure CreateMTWithDsrc(AOwner: TComponent; var AMT: TkbmMemTable; var ADsrc: TDataSource; const AMTName, ADsrcName: String); procedure InputFloatToRelatedZeroFieldInMT(AMemTable: TkbmMemTable; AEditingValue: Double; AEditingFieldName, ARelatedFieldName, AFieldsToZero, AInputPromt: String; AConvertInputedFromUOMToM: Boolean; AUOM: Integer); procedure DefineMTPriceFields(AMT: TkbmMemTable; APriceFields: TStringList; AOldCurr, ANewCurr: TCurrency); procedure DefineTablePriceFields(ATableName: String; APriceFields: TStringList; AOldCurr, ANewCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery; AIDListToDefine: TIntList); function CalcNormResourceCount(AUserCount, ALength, AExpenseForLength, ACountForPoint, AStepOfPoint: Double; ARoundIfExpenseForLength: Boolean): Double; procedure ChengeCurrencyRatiosWithPrices(AOldCurr, ANewCurr, ANewSecondCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery); function ChangeCurrencyMainMT(AMTCurrencies, AMTNorms, AMTResources: TkbmMemTable; const AMainGUID: string): TCurrency; procedure ChangeComponsCurrencyRatiosWithPrices(AIDCompons: TIntList; AOldCurr, ANewCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery); procedure ChangeObjectCurrencyRatiosWithPrices(AIDCatalog: Integer; AOldCurr, ANewCurr, ANewSecondCurr: PObjectCurrencyRel; AQSelect, AQOperat: TpFIBQuery); procedure ChangePricesByNDS(AOldNDS, ANewNDS: Double; AQSelect, AQOperat: TpFIBQuery); procedure CorrectCurrency(var ACurrency: TCurrency); //*** Вернет ID-ки всех компонент, которые подчиняются валютам папок function GetCompoIDsInCatalogCurrencies(AQSelect: TpFIBQuery): TIntList; function GetCountryCurrency(AQuery: TpFIBQuery): TCurrency; function GetCurrenciesNameBriefListFromNB: TStringList; function GetCurrencyByFieldValue(AFldByName: String; AFldValue: Variant; AQuery: TpFIBQuery): TCurrency; function GetCurrencyByID(ACurrencyID: Integer; AQuery: TpFIBQuery): TCurrency; function GetCurrencyByGUID(ACurrencyGUID: String; AQuery: TpFIBQuery): TCurrency; function GetCurrencyByType(ACurrencyType: Integer; AQuery: TpFIBQuery): TCurrency; function GetCurrencyFromDataSet(ADataSet: TpFIBDataSet): TCurrency; function GetCurrencyFromMemTable(AMemTable: TkbmMemTable): TCurrency; function GetCurrencyFromQuery(AQuery: TpFIBQuery): TCurrency; function GetCurrncyIDFromForm(ACurrCurrnecyID: Integer): Integer; //*** Валюты объектов procedure CreateDefCurrenciesForObject(AIDCatalog: Integer; AQSelect, AQOperat: TpFIBQuery; AFromList: TList = nil); procedure CreateDefCurrenciesForObjectsByLevel(AQSelect, AQOperat: TpFIBQuery); procedure DeleteObjectCurrencies(AIDCatalog: Integer; AQOperat: TpFIBQuery); function GetDefCurrenciesForObject(AIDCatalog: Integer; AQSelect: TpFIBQuery): TList; function GetDefObjectCurrencyByIDCurrency(AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetDefObjectCurrencyByMainFld(AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetObjectCurrencies(AIDCatalog: Integer; AQSelect: TpFIBQuery): TList; function GetObjectCurrencyCount(AIDCatalog: Integer; AQSelect: TpFIBQuery): Integer; function GetObjectCurrencyByIDCurrency(ACatalogID, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetObjectCurrencyByCurrencyIDFromList(AIDCurrency: Integer; AList: TList): PObjectCurrencyRel; function GetObjectCurrencyByGUIDCurrency(ACatalogID: Integer; AGUID: String; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetObjectCurrencyByGUIDCurrencyFromList(AGUID: String; AList: TList): PObjectCurrencyRel; function GetObjectCurrencyByIntFld(ACatalogID, AFldValue: Integer; AFldName: String; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetObjectCurrencyByMainFld(ACatalogID, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetObjectCurrencyByMainFldFromList(AMainValue: Integer; AList: TList): PObjectCurrencyRel; function GetObjectCurrencyFromQuery(AQuery: TpFIBQuery): PObjectCurrencyRel; function GetPriceAfterChangeNDS(APrice, AOldNDS, ANewNDS: Double): Double; function GetPriceAfterChangeCurrency(APrice: Double; AOldCurrency, ANewCurrency: TCurrency; AEpsilon: Integer = 3): Double; procedure SaveObjectCurrency(AMakeEdit: TMakeEdit; AObjectCurrency: PObjectCurrencyRel; AQSelect, AQOperat: TpFIBQuery); procedure ConvertSCSNormsToInterfNormsInfo(ASCSNorms: TObject; AInterfNormsInfoList: TList); // Вернет все Childы папки function GenCatalogSortIDByIDParent(AIDParent: Integer; AQSelect: TpFIBQuery): Integer; function GetCatalogAllChildsIDs(AIDCatalog: Integer; AQSelect: TpFIBQuery): TIntList; function GetCatalogAllComponIDs(AIDCatalog: Integer; AFromChild: Boolean; AQSelect: TpFIBQuery): TIntList; // Вернет валюту папки AIDCatalog, по полю AMainValue function GetCatalogCurrencyByCurrencyID(AIDCatalog, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; // Вернет валюту папки AIDCatalog, по полю AMainValue function GetCatalogCurrencyByMainFld(AIDCatalog, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; // вернет список всех папок уровня ALevel function GetCatalogIDsByLevel(ALevel: Integer; AQSelect: TpFIBQuery): TIntList; function GetCatalogChildsID(AParentID: Integer; ASortFld: String; AQSelect: TpFIBQuery): TIntList; function GetParentCatalogIDByLevel(AIDCatalog, ALevel: Integer; AQSelect: TpFIBQuery): Integer; function GetParentCatalogPathIDByLevel(AIDCatalog, ALevel: Integer; AQSelect: TpFIBQuery): TIntList; function GenComponSortIDByIDCatalog(AIDCatalog: Integer; AQSelect: TpFIBQuery): Integer; // Вернет ID папки, в которой находится компонент AIDComponent function GetComponCatalogOwnerID(AIDComponent: Integer; AQSelect: TpFIBQuery): Integer; function GetComponCatalogOwnerIDByLevel(AIDComponent, ALevel: Integer; AQSelect: TpFIBQuery): Integer; function GetComponCatalogOwnerPathIDByLevel(AIDComponent, ALevel: Integer; AQSelect: TpFIBQuery): TintList; // Вернет валюту компоненты function GetComponCurrencyByCurrencyID(AIDComponent, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; function GetComponCurrencyByMainFld(AIDComponent, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; // Вернет ID папки, в которой находится компонент AIDComponent function GetComponIDsFromCatalogs(ACatalogIDs: TIntList; AQSelect: TpFIBQuery): TIntList; procedure GetComponsResourcesID(AIDComponents: TIntList; ADestNormResRelID, ADestResourcesID: TIntList; AQSelect: TpFIBQuery); procedure GetComponsNormsID(AIDComponents: TIntList; ADestNormsID: TIntList; AQSelect: TpFIBQuery); function GetComponentTypeFromQuery(AQuery: TpFIBQuery): TComponentType; function GetPropertyDataFromQuery(AQuery: TpFIBQuery): TPropertyData; function GetPropValRelDataFromQuery(AQuery: TpFIBQuery): TPropValRelData; function GetPropValNormResData(AQuery: TpFIBQuery): TPropValNormResData; function GetSuppliesKindFromQuery(AQuery: TpFIBQuery): TSuppliesKind; procedure DefineSuppliesKindWorkValuesToFields(var ASuppliesKind: TSuppliesKind; AUOM: Integer); //*** Рихтовка компонент procedure ClearSpareComponPropertues(AQSelect, AQOperat: TpFIBQuery); procedure DefineComponKolComplects(AQSelect, AQOperat: TpFIBQuery); procedure DefineCatalogKolItemsCompons(AQSelect, AQOperat: TpFIBQuery); // Определяет количество элементов procedure DefineDirTypeContentCount(AQSelect, AQOperat: TpFIBQuery; ADirTypeIDs, ADirTypeRelIDs: TIntList); // Определяет количество подпапок и элементов в дереве справочника procedure DefineDirTypeChildContentCount(AQSelect, AQOperat: TpFIBQuery); // Опрередлит значения для пустых полей ID_TOP_COMPON в COMPONENT_RELATION procedure DefineIndividualComplectsByEmptyIDTopCompon(AQSelect, AQOperat: TpFIBQuery); // Определяет свойство сечение для линейных компонентов, если такое не определено procedure DefinePropSectionForLineCompons(AQSelect, AQOperat: TpFIBQuery; const APropSysName: String; ACompTypeSysNames: TStringList; ASrcInterfGender: ShortInt; ASetZeroIfNoValue: Boolean); procedure ChangeComponentCypher(ANewCypherPart: String; AIndex: Integer; AQSelect, AQOperat: TpFIBQuery); //procedure AddPropertyToComponents(AIDComponentType, AIDProperty: Integer); procedure RecalcNBComponentPrices; function GetCableChannelElementByName(const ATypeName: String): Integer; function GetCableChannelElementName(ATypeIndex: Integer): String; function GetCompStateTypeName(AType: Integer): string; function GetCCEGuid(ATypeIndex: Integer): String; function GetConnectionRelTypeName(AValue: Integer): String; function GetDataTypeName(ADataTypeID: Integer): String; function GetPlaneMaterialTypeName(AValue: Integer): String; function GetResourceTypeName(AResTypeIndex: Integer): string; function GetResourceTypeByName(const AResTypeName: string): Integer; function GetResourceTypeCorrectByCypher(const ACypher: string; ACurrResType: Integer): Integer; function GetTubeConnectKindByName(const AConnectKindName: String): Integer; function GetTubeConnectKindName(AConnectKindIndex: Integer): String; //*** Вид поствки function GetSuppliesKindByIzmAndKolvo(const AName, AIzm: String; AUnitKolvo: Double; ASuppliesKinds: TList): PSuppliesKind; function GetStringByTemplate(ASrcString, ATemplate: String): String; function GetLastCableCanalConnectorID(AGDBMode: TDBKind): Integer; function GetLastComponentID(AGDBMode: TDBKind): Integer; function GetLastInterfRelID(AGDBMode: TDBKind): Integer; function GetLastInterfOfInterfRelID(AGDBMode: TDBKind): Integer; function GetLastCompRelID(AGDBMode: TDBKind): Integer; function GetLastCompPropRelID(AGDBMode: TDBKind): Integer; function GetLastNormID(AGDBMode: TDBKind): Integer; function GetLastNormResourceID(AGDBMode: TDBKind): Integer; function GetLastPortInterfRelID(AGDBMode: TDBKind): Integer; function GetParallelSide(ASide: Integer): Integer; function GetIsActiveFormProgress: Boolean; procedure PauseProgress(APaused: Boolean); procedure PauseProgressByMode(APaused: Boolean); function GetIsLineByComponType(AComponType: TComponentType): Integer; function isLineCompon(AForm: TForm; AIDComponent: Integer): Boolean; function IsArchComponByIsLine(AIsLine: Integer): Boolean; function IsArchComponByItemType(AItemType: Integer): Boolean; function IsArchCornerComponByIsLine(AIsLine: Integer): Boolean; function IsArchBalconyChildComponByIsLine(AIsLine: Integer): Boolean; function IsArchRoomComponByIsLine(AIsLine: Integer): Boolean; function IsArchTopComponByIsLine(AIsLine: Integer): Boolean; // Стена, или перестенок - любой сегмент function IsArchSegmentComponByIsLine(AIsLine: Integer): Boolean; function IsArchSegmentIn3DByIsLine(AIsLine: Integer): Boolean; // стена, ребро крыши - арх. сегмент из каркаса function IsArchFrameSegmentComponByIsLine(AIsLine: Integer): Boolean; // Окно, дверь, арка, ниша, балкон function IsArchWallChildComponByIsLine(AIsLine: Integer): Boolean; // откос function IsSlopeComponByIsLine(AIsLine: Integer): Boolean; function IsProperItemTypeToIsLine(AItemType, AIsLine: Integer): Boolean; function HaveComponFunctionalInterfaces(AQuery: TObject; AIDComponent: Integer): Boolean; function GetItemTypeByIsLine(AIsLine: Integer): Integer; function GetFolderComponList(AFormBase: TForm; AFolder: TObject; AObjectTypes: TIntSet): TList; procedure RefreshComponsLengthByList(AIDList: Integer); procedure RefreshComponMarks(AIDParentCatalog: Integer); procedure RefreshListItems(AListID: Integer; AItemTypes: Integer; AForSelected: Boolean); function GetJoinedAllLinesToPointCompon(AIDPointComponent: Integer; APointComponent: TObject): TObject; // TSCSComponents function GetNetFromComponenet(AComponent: TObject; const AGUIDNetTypeJoinedToPoint: String; ATakeIntoAutoTracing: Boolean): TList; // PConnectedComponents function GetLineComponsInTrace(AIDComponent: Integer; AObjComponent: TObject): TWholeLineCompon; function GetLineComponsInTraceFromBase(ALineComponent: TObject; ALoadComponIDs: Boolean): TWholeLineCompon; procedure GetFirstLastLineComponsFromComponsInTrace(ATraceCompons: TList; var AFirstCompon: Integer; var ALastCompon: Integer); function GetTraceByListCompon(AListCompon: TIntList): TIntList; function GetTraceByListOjects(AListObjects: TList): TList; function GetTraceInfoFromListByPosition(ATraceInfo: TList; APosition: TTraceTypePorition): TList; function GetTraceInfoFromListByHorzHeight(ATraceInfo: TList; ALoHeight, AUpHeight: Double; ALoHitToBoundIfBetween, AUpHitToBoundIfBetween: Boolean; ALoadedTracesInfo: TList = nil): TList; function GetTraceInfoFromListBySelected(ATraceInfo: TList; ASelected: Boolean): TList; function GetTraceInfoNoHitToListByFigureID(ATraceInfo: TList; AList: TList): TList; function GetFigureIDsBetweenOnWholeComponent(ALineComponent: TObject): TIntList; function GetProjectLists(AIDCatalogProject: Integer): TList; function CheckIsMetricUOM(AUOM: Integer): Boolean; function CheckIsTradUOM(AUOM: Integer): Boolean; function CheckPriceTransformToUOMByCompType(ACompType: PComponentType): Boolean; function GetComponNameForVisible(AName, ANameMark: String): String; function GetNameAndKol(AName: String; AKol: Integer): String; function GetNameWithIndex(const AName: String; AIndex: Integer): String; function GetNameAndIndex(AName: String; AItemType, AIndexPointObj, AIndexConn, AIndexLine: Integer): String; function GetNameAndIndexByTCatalog(ACatalog: TCatalog): String; function GetNameAndIndexByTSCSCatalog(ASCSCatalog: TObject): String; function GetNameInterfaceMultipleForLine: String; function GetNameUOM2(AUOM: Integer): String; function GetNameUOM3(AUOM: Integer): String; function GetNameUOM(AUOM: Integer; AAsShort: Boolean; ACanUseShortSign: Boolean=true): String; function GetNameUOMForCompon(AIzm: String; ACompType: PComponentType; AUOM: Integer): String; function GetNameUOMForProperty(const APropIzm, ASysName: String; AUOM: Integer): String; function GetUOMFromPM: Integer; procedure SetUOMToPM(AUOM: Integer); //function MakeMarkMaskForComponent(AProj, AList, ARoom, AObj, ATopCompon, ACompon, APort: Integer; // const AComponNameShort, AMask: String): String; //procedure EditCatalogMarkMasksExecute(AID: Integer; AItemType: Integer = itList); function GetNBMarkTemplates: TList; function GetMarkMaskTemplateByCompTypeFromList(ATemplatesList: TList; AComponentType: Integer): PCatalogMarkMask; function GetNBSettingsAsDefault: TNBSettingRecord; function GetNBSettings(AQuery: TpFIBQuery): TNBSettingRecord; procedure SetNBSettings(ANBSettings: TNBSettingRecord; AQuery: TpFIBQuery); function GetDBTypeByFileExtension(AFileName: String): Integer; function GetTableNameByDBType(ADBType: Integer): String; function GetTableNameFromTableFieldStr(ATableFieldStr: string): string; function GetFieldNameFromTableFieldStr(ATableFieldStr: string): string; procedure AddNBComponGUIDToFreqUseObjByID(AComponID: Integer); procedure AddComponGUIDToNBFavorites(AGUID: String); procedure DelComponGUIDFromNBFavorites(AGUID: String); function CheckExistsComponGUIDInNBFavorites(AGUID: String): Boolean; function GetComponGUIDsFromNBFavorites: TStringList; procedure AddFieldToTable(const ATableName, AFieldName: String; AFieldType: TFieldType; ASize: Integer; AQOperat: TpFIBQuery); procedure AppendIDNameToMemTable(AID: Integer; const AName: String; AMemTable: TkbmMemTable); procedure BlobFieldToStrings(ABlobField: TBlobField; AStrings: TStrings); procedure BlobFieldFromStrings(ABlobField: TBlobField; AStrings: TStrings); function CheckConnectCountNoMoreOneToDataBase(ADataBase: TpFIBDataBase; AMessgFalse: string=''): Boolean; function CheckConnectCountNoMoreOneToNB(AMessgFalse: string=''): Boolean; function CheckConnectCountNoMoreOneToPM(AMessgFalse: string=''): Boolean; function CheckFieldInTable(const ATableName, AFieldName: String; AQSelect: TpFIBQuery): Boolean; function CheckFieldInTableByFirstRec(ATableName, AFieldName: String; AQuery: TpFIBQuery): Boolean; function CheckLocate(ADataSet: TDataSet; AFieldName: String; AValue: Variant): Boolean; function CheckStrValueInTable(const ATableName, AFieldName, AValue: String; ANoIncludingID: Integer; AQuery: TpFIBQuery): Boolean; function CheckValueInMT(AMemTable: TkbmMemTable; AFieldName: String; AValue: Variant): Boolean; function CheckExistsTableInBase(AQSelect: TpFIBQuery; ATableName: String): Boolean; function CopyBase(ASrcDBName, ANewDBName: String; ADelSrcBase: Boolean = false): Boolean; procedure CopyBlobFromFNToParamInQuery(ADestQuery, ASrcQuery: TpFIBQuery; AParamName, AFieldName: String); procedure DeactiveDataSets(AComponentOwner: TComponent); procedure DefineBusyFieldsInBase(AQSelect, AQOperat: TpFIBQuery); procedure DefineSpavIDsBySpravGUIDs(ADestTableName, ASpravTableName, ADstFieldNameID, ADstFieldNameGUID: String; AQSelect, AQOperat: TpFIBQuery); procedure DelFieldFromTable(const ATableName, AFieldName: String; AQOperat: TpFIBQuery); function GetAllIDsFromTable(ATableName: String; AQSelect: TpFIBQuery): TIntList; function GetBaseNow(AQSelect: TpFIBQuery): TDateTime; function GetBaseParam(AParamName, AValue: String): String; function GetConnectedCountToDataBase(ADataBase: TpFIBDataBase): Integer; function GetDirItemTypeByGuideFileType(AGuideFileType: Integer): Integer; function GetFieldNamesFromFIBQuery(AQuery: TpFIBQuery): TStringList; function GetFieldLengthInTable(ATableName, AFieldName: String; AQSelect: TpFIBQuery): Integer; function GetFieldPositionInTable(ATableName, AFieldName: String; AQSelect: TpFIBQuery): Integer; procedure GetFieldInfo(const ATableName, AFieldName: String; AQSelect: TpFIBQuery); function GetFieldsFromTable(const ATableName: String; AFieldTypes: TIntList; AQSelect: TpFIBQuery): TStringList; function GetMasterFNameByDirItemType(ADirItemType: Integer): String; function GetSQLByParams(AQueryType: TQueryType; const ATableName, AWherePart: String; AFieldList: TStringList; const AOneFieldName: String): String; function GetSQLFieldsAsStr(AFields: TStrings; const APref: String=''): String; function GetSQLForAddFieldToTable(ATableName, ANewFieldName: String; AFieldType: TFieldType; ASize: Integer; AQueryMode: TQueryMode): String; function GetSQLForDropField(ATableName, AFieldName: String): String; function GetSQLForDropIndex(AIndexName: String): String; function GetSQLForInsertCompRel: String; function GetSQLForIsVisible(ATableName: string): string; function GetSQLForIsVisibleWithFieldIntValue(ATableName, AFiledName: string; AFieldValue: Integer): string; function GetSQLOpeatorIN(AFieldName, APreviosConditions: String; AIDList: TintList): string; function GetStrFieldType(AFieldType: TFieldType; ASize: Integer): String; function GenIDFromTable(AQSelect: TpFIBQuery; const AGeneratorName: String; AIncr: Integer): Integer; function GetFileStreamFromTableByID(ATableName, AFieldName, ATrgFile: String; AID: Integer; AQuery: TpFIBQuery): TFileStream; function GetIntFromTableByGUID(ATableName, AResFieldName, AGUID: String; AQuery: TpFIBQuery): Integer; function GetIntFromTableByID(ATableName, AResFieldName: String; AID: Integer; AQuery: TpFIBQuery): Integer; //05.04.2012 function GetIntFromTableByFld(const ATableName, AField, AResFieldName, AVal: String; AQuery: TpFIBQuery): Integer; function GetStreamFromTableByID(ATableName, AFieldName: String; AID: Integer; AQuery: TpFIBQuery): TMemoryStream; function GetStringFromStream(AStream: TStream): String; function GetStringFromTableByGUID(ATableName, AFieldName, AGUID: String; AQuery: TpFIBQuery): String; function GetStringFromTableByID(ATableName, AFieldName: String; AID: Integer; AQuery: TpFIBQuery): String; function GetTableFieldsNames(ATableName: String; AQuery: TpFIBQuery): TStringList; function GetTableIndexByGeneratorIndex(AGeneratorIndex: Integer): Integer; function GetTableNameByGeneratorIndex(AGeneratorIndex: Integer): String; function GetTableNameByGUIDFieldPointer(AGUIDFieldPointer: String): String; function GetTableNameByTableIndex(ATableIndex: Integer): String; function GetTablesFromBase(AQSelect: TpFIBQuery): TStringList; function GetTimeUOMName(const aVal: Integer): String; function GetValueFromTable(ATableName, AResFieldName, AFldBy: String; AFldValue: Variant; AQuery: TpFIBQuery): Variant; function GetValueFromTableFirst(ATableName, AResFieldName: String; AQuery: TpFIBQuery): Variant; procedure IntFIBFieldToIntList(AIntList: TObject; AQuery: TpFIBQuery; const AFieldName: String); procedure StrFIBFieldToStringList(AStringList: TStringList; AQuery: TpFIBQuery; const AFieldName: String); procedure CopyStream(ADest, ASrc: TStream); // Открытие фала, который может быть занят временно другим процессом function SafeOpenFileStream(AFilePath: string; AMode: Word; AProcedureName: string=''; AMsgIfFail: String=''): TFileStream; //procedure MemTableEdit(AMemTable: TkbmMemTable; FieldNames: String; Arr); //procedure OpenBaseResultHandler(AOpenBaseResult: TOpenBaseResult; AForm: TForm; ACanReconnect, ACanExitProc: Boolean); procedure OpenBaseResultHandler(AOpenBaseResult: TOpenBaseResult; AForm: TForm; ACanReconnect, ACanExitProc: Boolean; aConnType: integer = 0); procedure UpdateNormBaseResultHandler(AUpdateReults: TUpdateBaseResults; ASrcPath: String); function LoadBufferFromFile(var ABuffer; ASize: Integer; AFileName: string): Boolean; procedure LoadFromStreamToMT(AMemTable: TkbmMemTable; AStream: TStream; const AFieldName: String); procedure LoadFromStreamToQr(var AQuery: TpFIBQuery; var AStream: TStream; AParamName: String; AFreeStream: Boolean); procedure LoadFromStreamToSQLMT(AMemTable: TSQLMemTable; AStream: TStream; AFieldName: String); procedure LoadMTFromFIBQuery(AMT: TkbmMemTable; AQSelect: TpFIBQuery); function SaveBlobFieldToFile(ATableName, AFieldName, ATrgFile: String; AID: Integer; AQuery: TpFIBQuery): Boolean; procedure SaveBufferToFile(var ABuffer; ASize: Integer; AFileName: string); procedure SaveToStreamFromMT(AMemTable: TkbmMemTable; AStream: TStream; AFieldName: String); procedure SaveToStreamFromQr(var AQuery: TpFIBQuery; var AStream: TStream; AFieldName: String; ACreateStream: Boolean); procedure SaveToStreamFromSQLMT(AMemTable: TSQLMemTable; AStream: TStream; AFieldName: String); procedure SaveToStringListFromQr(AQuery: TpFIBQuery; AStringList: TStringList; AFieldName: String; AUnPack: Boolean); procedure SetBusyParamsToBase(AQSelect, AQOperat: TpFIBQuery; ABusyType: Integer); procedure SetFieldInfo(const ATableName, AFieldName, AParamName: String; AValue: Variant; AQSelect, AQOperat: TpFIBQuery); procedure SetFieldPositionInTable(ATableName, AFieldName: String; APosition: Integer; AQOperat: TpFIBQuery); procedure SetNBType(ANBType: Integer; AQSelect, AQOperat: TpFIBQuery); procedure SetDayKolvo(Kolvo: Integer; AQSelect, AQOperat: TpFIBQuery); function GetDayKolvo(Query_Select: TpFIBQuery): integer; procedure SetParamAsBufferToQuery(AQuery: TpFIBQuery; AFldName: String; var ABuffer; ABuffSize: Integer); procedure SetParamAsInteger0AsNullToQuery(AQuery: TpFIBQuery; AFldName: String; AValue: Integer); procedure SetParamAsStreamToQuery(AQuery: TpFIBQuery; const AFldName: String; AValue: TStream; APack: Boolean=false); procedure SetParamAsStringEmptyAsNullToQuery(AQuery: TpFIBQuery; const AFldName, AValue: String); procedure SetParamAsStringListToQuery(AQuery: TpFIBQuery; const AFldName: String; AStringList: TStrings; APack: Boolean); procedure SetSQLToFIBQuery(AQuery: TpFIBQuery; const ASQL: String; AExecute: Boolean = true); procedure SetSQLToFIBQueryWithCheckSQL(AQuery: TpFIBQuery; ASQL: String; AExecute: Boolean = true); procedure SetStreamToTableByID(ATableName, AFieldName: String; AID: Integer; AStream: TStream; AQOperat: TpFIBQuery); procedure StoreGuidsInReservGuidTable(ADataBase: TpFIBDataBase; AReservGuidSize: Integer); //function TextToOEM(const aText: String): String; function TextToOEM(const aText: AnsiString): String; function TextToUTF16LE(const aText: String): String; procedure UpdateTableFieldAllRec(AQOperat: TpFIBQuery; ATableName, AUpdFieldName: String; ANewValue: Variant); procedure UpdateTableIntFieldRecsFromListID(AQOperat: TpFIBQuery; const ATableName, AUpdFieldName: String; ANewValue: Variant; ASrcIDList: TIntList); procedure UpdateTableFieldStreamAllRec(AQOperat: TpFIBQuery; ATableName, AUpdFieldName: String; ANewValue: TStream); function GetLastIDFromSQLMemTable(AMemTable: TSQLMemTable; const AIDFName: String): Integer; procedure ExchangeDouble(var AValue1 , AValue2: Double); procedure ExchangeIntegers(var AInt1, AInt2: Integer); procedure ExchangeObjects(var AObj1, AObj2); function CheckIsActiveKeyboardOrMouse: Boolean; function GetNBNow: TDateTime; function GetPMNow: TDateTime; procedure AutoSaveCurrentProject; function SaveDialogChecker(ASaveDialog: TSaveDialog): Boolean; procedure SaveProjectDateTime; // ####################### Связь с CAD-ом ###################################### // ############################################################################# {<# // Олегу для ТЕСТА (закоментировать!) Procedure SetNewObjectNameInCad(AID_Figure: Integer; AOldObjName, ANewObjName: String); Procedure DeleteObjectFromCad(AID_Figure: Integer; AObjName: String); Procedure SelectObjectInCAD(AID_Figure: Integer; AObjName: String); Procedure AddListInCAD(ListID: Integer; ListName: String); Procedure SwitchListInCAD(ListID: Integer; ListName: String); Procedure RenameListInCAD(ListID: Integer; OldListName, NewListName: String); Procedure DeleteListInCAD(ListID: Integer; ListName: String); Procedure AppendLineInterfacesToCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TInterfLists); Procedure AppendNoLineInterfacesToCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TList); procedure RemoveLineInterfacesFromCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TInterfLists); Procedure RemoveNoLineInterfacesFromCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TList); procedure SelectTraceInCAD(ATraceList: TList); procedure DeselectTraceInCAD; function GetLineFigureInterfListsFromCAD(AIDFigure: Integer): TInterfLists; // процедуры для изменения высоты обьетов на КАД procedure SetLineFigureCoordZInCAD(AID_Figure: Integer; ASide: Byte; ACoordZ: Double); procedure SetConFigureCoordZInCAD(AID_Figure: Integer; ACoordZ: Double); #>} function CreateSimpleRoomInPM(ACallFrom: TCallFrom; ASCSList: TObject; ARoomParams: TObjectParams; AReGroupObjects: Boolean): TObjectParams; function CreateRoomFromCADToPM(AListID: Integer): TObjectParams; procedure DeleteRoomFromCADToPM(ARoomID: Integer); function GetRoomParamsForNew(ASCSList: TObject): TObjectParams; procedure MoveObjectToRoomInPM(AListID, AObjectID, ANewRoomID: Integer); Function SendObjectToPrjManager(ID_Figure, ID_CAD, AIDRoom: Integer; const ObjName: String; ASCSObjectKind: TSCSObjectKind): TTreeNode; function CopyComponentToPrjManager(ListNode: TTreeNode; ID_Figure, ID_CAD{, AIDCopyCompon}: Integer; AComponToCopy: TObject; ACreateObjectOnClick: Boolean; AFromHuman: Boolean = false): Integer; // NEW!!! function CopyComponentToSCSObject(AID_Figure, AIDCopyCompon: integer; AFromHuman: Boolean = false; AOutSCSObj: Pointer=nil): Integer; procedure DublicateObjectComponents(AIDSrcFigure, AIDTrgFigure: Integer); function ComplectNBComponToProjObj(AFigureID: Integer; ANBCompon: TObject; AOnlyCheck: Boolean): Boolean; function ComplectNBComponToProjCompon(AIDProjCompon: Integer; ANBCompon: TObject; AOnlyCheck: Boolean): Boolean; Procedure SetNewObjectNameInPM(ID_Figure: Integer; ObjName: String); Procedure SetNewListNameInPM(AIDList: Integer; ANewName: String); function GetListNameFromPM(AIDList: Integer): String; Procedure AddConnObjectInPM(ID_Figure, AIDRoom: Integer; ObjName: String); function CanDelSCSObject(AObject: TObject): Boolean; function BeforeDelObjectFromPM(ACallFrom: TCallFrom; AListID, AFigure: Integer; ARelatedLists: TIntList=nil): Boolean; Procedure DeleteObjectFromPM(ID_Figure: Integer; const ObjName: String; aIsManual: Boolean=false); procedure SetObjectToDeleteInPM(AIDFIgure: Integer); Procedure ShowObjectInPM(AID_Figure: Integer; AObjName: String; aShowNode: Boolean = True); Function GetTreeNodeByID(AID_Figure: Integer): TTreeNode; procedure SelectComponentInNB(AIDComponent: Integer); function IsEmptyFigure(AIDFigure: Integer): Boolean; function IsHaveObjectCableChannel(AObject: TObject): Boolean; function IsHaveFigureCableChannel(AListID, AFigureID: Integer): Boolean; function CheckEmptyFigure(AIDFigure: Integer): Boolean; procedure EditFirstFigureComponent(AIDFigure: Integer); // Процедуры для взаимодействия Листа в МП и Листа в CAD-е Function AddProjectInPM: TTreeNode; //new Function OpenProjectInPM(AIDLastList: Integer): TList; //new function GetCurrProjectName: String; function CanAddListToPM(var AWasOpenProject: Boolean): Boolean; Function AddListInPM(AListID: Integer; AListParams: TListParams): TTreeNode; Function OpenListInPM(AListID: Integer; ALIstName: String; var AFileName: String): TMemoryStream; //new Procedure SwitchListInPM(AListID: Integer; AListName: String); procedure DeleteListInPM(AListID: Integer; AListName: String); procedure AfterCloseListInCAD(AListID: Integer); function ExistsOpenedCAD: Boolean; function ExistsSCSObjectInList(AIDList: Integer): Boolean; procedure OpenNoExistsListInCAD(AListObject: TObject); procedure SetIsOpenedListInCADToPM(AListID: Integer; AOpened: Boolean); function IconToFile(AFileName: String): TCompStateType; //function GetJoinComponsIDs(AIDServerCompon, AIDWSCompon: Integer; // var AResLength: Double; AThroughPointCompon: Boolean): TIntList; function GetJoinComponsIDs(AServerCompon, AWSCompon: TObject; var AResLength: Double; AThroughPointCompon: Boolean): TIntList; function GetJoinComponsIDsAccountComplects(AIDServerCompon, AIDWSCompon: Integer; var AResLength: Double): TIntList; function GetComponentsJoiningCatalogs(ASCSIDCatalog1, ASCSIDCatalog2: Integer; var AResLength: Double): TIntList; //17.01.2013 function GetAllTrace(AIDFigureServer, AIDFigureWS: Integer): TIntList; function GetAllTraceWithProperties(AIDFigureServer, AIDFigureWS: Integer): TTraceWithProperties; function GetConnectedTracesToConFigure(AIDConFigure: Integer): TList; procedure FreeTrace(ATraceList: TList); // получить лист с ID всех линий в трассе function GetComponLineTrace(AIDComponent: Integer): TIntList; function GetCablesCountFromTrace(AFigureID, ASide, AIDNBCable: Integer): Integer; function GetLineInterfacesFromPM(AIDFigure: Integer): TInterfLists; function GetNoLineInterfacesFromPM(AIDFigure: Integer): TList; // функции для конекта и дисконекта обьектов (по их интерфейсам) function CanLineComponLieToTrace(ASCSComponent: TObject): Boolean; function HaveObjectComponentByType(AIDFigure: Integer; AComponType: String; AWithOutOtherType: Boolean; AIsTemplate: Integer): Boolean; // Есть ли в объекте компонент с типом из списка function HaveObjectComponentByTypes(AIDFigure: Integer; AComponTypes: TStringList; AWithOutOtherType: Boolean): Boolean; // Есть ли в объекте компоненты, которые свободно могут быть на высоте размещения трасс (заглушки, распределительные коробки) function HaveObjectCorkComponent(AIDFigure: Integer): Boolean; function HaveObjectCupboardComponent(AIDFigure: Integer): Boolean; function HaveObjectSocketComponent(AIDFigure: Integer): Boolean; function CheckCanJoinNBComponWithPointObjects(ANBComponent: TObject; AEndPointFigure, AFigureSnap: TObject): Boolean; function CanConnectLineComponWithConObjects(AIDNBLineCompon, AIDPointFigure, AIDFinalFigure: Integer; aConsiderBoxAndRack: Boolean=false): Boolean; function ConnectObjectsInPM(AConnectObjectParams1, AConnectObjectParams2: Tlist): Boolean; function ConnectObjectsInPMByWay(AWay: TIntList; AFigures, ASCSObjs: TList; APosList: TIntList = nil; aConsiderBoxAndRack: Boolean=false): Boolean; function DisconnectObjectsInPM(AIDObjectList1, AIDObjectList2: Tlist): Boolean; function GetEndPointParamsFromList(AIDList: Integer; AOnlyCupBoard: Boolean): TList; procedure FreeLineFigureInterfaces(AIDFigure, ASide: Integer); function GetPairCountFromTrace(AListID, ATraceFigureID: Integer): string; function GetFigureInterfacesToConnect(AIDFigure: Integer): TList; function GetConnectorsByInterfaces(AInterfIDList: TList): TList; function GetCopyConnectObjectParams(AConnectObjectParams: TList): TList; // функции для передачи-получения Stream в-из МП {procedure GetStreamFromPM(AStream: TMemoryStream); procedure GetStreamToPM(AStream: TMemoryStream); } function GetCadDataFromPM(AIDList: Integer; var AFileName: String): TMemoryStream; function GetCadFileNameForSaveToPM(AIDList: Integer): string; function GetLengthBetweenFigures(AIDFigure1, AIDFigure2: Integer): Double; function SetCadDataToPM(AIDList: Integer; AStream: TMemoryStream): Boolean; function ListToDeleting(AIDList: Integer): Boolean; procedure SetLineFigureCoordZInPM(AIDFigure, ASide: Integer; ACoordZ: Double); procedure SetConFigureCoordZInPM(AIDFigure: Integer; ACoordZ: Double); procedure SetLineFigureLengthInPM(AIDFigure: Integer; ALength: Double); function MakeCablingInPM(AIDObjectList: Tlist; ASaveForUndo: Boolean=false): Boolean; function GetHowFillObjByEmptyBusy(AEmptyCnt, ABusyCnt: integer): TFillConnectConObj; function HowFillConnectConObj(AObject: TObject; AUseInterfFilter: Boolean): TFillConnectConObj; function HowFillConnectLineObj(AObject: TObject; AUseInterfFilter: Boolean): TFillConnectLineObj; function HowFillCableCanal(AObject: TObject): TFillConnectConObj; function HowFillCablaCanalCorkInTrace(AObject: TObject): TFillConnectLineObj; function GetObjDefectDegree(AObject: TObject): TDefectDegree; //*** Отчеты procedure RepObjectReport; //*** Ведомость объектов procedure RepResourceReport; //*** Ведомость ресурсов procedure RepCableReport; //*** Ведомость кабелей procedure RepCableExceedLength; //*** Ведомость кабелей с превышающей длиной procedure RepCableCanal; //*** Ведомость кабельных каналов procedure RepDisparityComponColor; //*** Ведомость подключений по несоотв. цветам procedure RepDisparityComponProducer; //*** Ведомость подключений по несоотв. продюсерам procedure RepCableJournal; //*** кабельный журнал procedure RepCableJournalExt; //*** Расширенный кабельный журнал procedure RepSpecification; //*** Отчет "Спецификация" procedure RepWizard; procedure RepMarkPages; //*** Справочники procedure ShowCurrencyDirectory; // Валюты procedure ShowNetTypeDirectory; // Типы сетей procedure ShowInterfaceDirectory; // Интерфейсы //procedure ShowInterfaceAccordanceDirectory; // Соответсвие интерфейсов procedure ShowPropertyDirectory; // Свойства объектов procedure ShowObjectIconsDirectory; // Условные обозначения procedure ShowProducersDirectory; // Производители procedure ShowComponentTypesDirectory; // Типы компонент procedure ShowNormsDirectory; // Нормы procedure ShowResourcesDirectory; // Ресурсы procedure ShowSuppliesKinds; // Виды поставок procedure ShowNDSDirectory; // НДС //*** сжатие баз procedure PackNormBase; procedure PackProjMan; //*** Резервирование/востановление procedure BackUpBase(ADefDBMode: TDBKind); procedure RestoreBase; procedure ShowMasterUpdatePriceInNB; //*** Настройки procedure ChoiceNBPath; //*** Путь к нормативной базе procedure ChoicePMPath; //*** Путь к базе менеджера проектов procedure ChoiceBaseOptions(ASettingTypeIndex: Integer = stiNone); //*** Опции нормативной базы procedure ClearSCSTemDirs; function CreateUniqueDirInSCSTmp: String; function FullRemoveDir(ADir: string; ADeleteAllFilesAndFolders, ARemoveRoot: boolean): Boolean; function GetDirFiles(const Path: string): TStringList; function GetPathToDefListSettings: String; function GetPathToDefNB: string; function GetPathToDefProjSettings: String; function GetPathToDevelopment: String; function GetPathToExeLoader: String; function GetPathToHelp(aRelative: Boolean): String; function GetPathToNBComponFavorites: String; function GetPathToNBComponFilter: String; function GetPathToNBComponGroups: String; function GetPathToNBEmpty: String; function GetPathToPackedTmp(AFileNoExists: Boolean): String; function GetPathToProjectTmp: String; function GetPathToProjectFilterTmp(AFileNoExists: Boolean): String; function GetPathToRedoDir(ADefine: Boolean=true): String; function GetPathToRepDesignLang: String; function GetPathToSCSCADDir(AWithCreate: Boolean=false): string; // Путь к папке, где хранятся открытые КАД листы function GetPathToSCSTmpDir: String; function GetPathToSCSUndoDir(ADefine: Boolean=true): String; //Tolik 11/07/2025 -- //function GetPathToSCSUndoUniqDir: String; function GetPathToSCSUndoUniqDir(aFor3D: Boolean = false): String; // function GetPathToUndoDir(ADefine: Boolean=true): String; function GetPathToUnPackedTmp(AFileNoExists: Boolean): String; function GetPathToUserReportFile(ARepFileName: String): String; //*** протокол procedure ShowLog; //*** Для U_SCSMAIN procedure MakeProject; procedure OpenProjectAtCurrNode; function CloseCurrProject(ACloseApplication: Boolean; AMessageIfClosed: Boolean = true): Integer; procedure LoadNewProjectFromFile; procedure MasterCableTracing; procedure MasterCableCanalTracing; function SaveCurrentProject: Boolean; procedure SaveProjectToFile; //*** Для Листа procedure ShowConfigurator; procedure ShowConfiguratorForPointObject(AIDPointFigure: Integer); // Калькулятор procedure ShowKalc; procedure ShowConnDisconnComponsForList(AListID: Integer; AModeConnDisconnCompons: TModeConnDisconnCompons); //*** Установка высот текущего листа //procedure SetCurrListHeightRoom(AHeight: Double); //procedure SetCurrListHeightCeiling(AHeight: Double); //*** для потолка //procedure SetCurrListHeightSocket(AHeight: Double); //*** для розеток //procedure SetCurrListHeightCorob(AHeight: Double); //*** для коробов //*** Передача высот текущего листа { function GetCurrListHeightRoom(AIDList: Integer): Double; function GetCurrListHeightCeiling(AIDList: Integer): Double; //*** для потолка function GetCurrListHeightSocket(AIDList: Integer): Double; //*** для розеток function GetCurrListHeightCorob(AIDList: Integer): Double; //*** для коробов } //*** Установка доп. параметров лин. объектов {procedure SetCurrListLengthKoef(ALengthKoef: Double); procedure SetCurrListPortReserv(APortReserv: Double); procedure SetCurrListMultiportReserv(AMultiportReserv: Double);} //*** Передача доп. параметров лин. объектов { function GetCurrListLengthKoef(AIDList: Integer): Double; function GetCurrListPortReserv(AIDList: Integer): Double; function GetCurrListMultiportReserv(AIDList: Integer): Double; } function GetIDLineComponFromNBByIDInterface(AIDInterface: Integer): Tlist; // Автосоединение через с-п // Tolik 26/09/2018 - - //function AutoConnectOverRaiseLine(APointObjectID: Integer; ARaiseLineID: Integer; // AJoinedBeforeRaise, AJoinedAfterRaise: TList; ALineType: TLineType = ltTrace): Boolean; function AutoConnectOverRaiseLine(APointObjectID: Integer; ARaiseLineID: Integer; AJoinedBeforeRaise, AJoinedAfterRaise: TList; ALineType: TLineType; aNoCopyList: TList = nil): Boolean; // function AutoDisconnectOverRaiseLine(ARaiseLineID: Integer; AJoinedBeforeRaise, AJoinedAfterRaise: TList): Boolean; // получить маркировку //Function GetFigureMarking(AID_Figure: Integer): string; function GetFigureComponNames(AIDFigure: integer): TStringList; function GetObjectStructuredNotes(AObject: TObject): TStringList; function GetObjectNotesByMarkStr(AObject: TObject; AShowType: TShowType): TStringList; function GetObjectNotesWithParams(AIDFigure: Integer): TStringList; // Call from CAD function GetObjectNotes(AObject: TObject): TStringList; function GetObjectPortMultyPortNameMarks(AObject: TObject): TStringList; // Получение полного имени объекта с учетом настроек Function GetFullNameWithOptions(AID_Figure: Integer; AShowNameType: TShowType): string; //function GetFigureIndex(AIDFigure: Integer): Integer; function GetFigureFirstComponentName(AIDFigure: Integer): string; procedure ReDefineObjectComponsNameMarks(AObject: TObject); //*** Настройки объекта procedure SaveFigureParams(AIDFigure: Integer; AFigureParams: TObjectParams); procedure SaveObjectParams(AObject: TObject; AFigureParams: TObjectParams); //Tolik 07/11/2018 -- вынесено в U_Common //function GetFigureParams(AIDFigure: Integer): TObjectParams; //function GetFigureParams(AIDFigure: Integer; AObjectCatalog: TSCSCatalog = nil): TObjectParams; // //*** Настройки Листа procedure SaveCADListParams(AIDList: Integer; AListParams: TListParams); procedure SaveListParams(AIDList: Integer; AListParams: TListParams; AForAllObjects: Boolean = true; AForSelectedobject: Boolean = true); function GetDefaultListSettings(aForNewList: Boolean; AUOM: Integer=-1): TListSettingRecord; function GetDefaultProjectSettings: TProjectSettingRecord; function GetDefaultRoomSettings: TRoomSettingRecord; function GetListParams(AIDList: Integer): TListParams; function GetListParamsForNewList: TListParams; //function GetListSettingsByICatalog(AIDCatalog: Integer): TListSettingRecord; function GetListDesignedName(ADesignFigureID: Integer): String; procedure LoadDefListSettingsFromFile(var AListSettings: TListSettingRecord); procedure LoadDefProjectSettingsFromFile(var AProjectSettings: TProjectSettingRecord); procedure DropCreatedObjCountOnClickInList(AListID: Integer); //*** Настрройки проекта function GetCurrProjectParams(AWithProjRights: Boolean=true): TProjectParams; function GetProjectParamsForNew(ALoadUserParams: Boolean): TProjectParams; function CheckProjectInUse(AIDProject: Integer; var AUserName: String; var AUserDateTime: TDateTime): Boolean; procedure SaveCurrProjectParams(AProjectParams: TProjectParams); function IsSelectServerAsDefault: Boolean; procedure ShowObjectProps(AIDObject: Integer); procedure MakeNewProject; procedure MakeNewList; function ShowCurrProjectProperties(ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; function ShowCurrListProperties(ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; procedure ShowListProps; procedure ShowRoomProps(ARoomID: Integer); procedure ShowRoomPropsInCAD(AListID, ARoomID: Integer); function GetListIDForCreatePassage(AID_CurList: Integer; AParam: Integer): Integer; function GetSortedListIDsByBounds(AIDEndList, AIDCurrList: Integer): TIntList; function GetUpperList(AIDList1, AIDList2: Integer): Integer; function GetCurrProectPointComponTypes: TObjectList; { // Олегу для ТЕСТА (закоментировать!) Procedure AddListInCAD(ListID: Integer; ListName: String); Procedure SwitchListInCAD(ListID: Integer; ListName: String); Procedure RenameListInCAD(ListID: Integer; OldListName, NewListName: String); } // для отправки типов сетей для объекта Function GetNetworkTypesForSCSObject(ASCSObject: TObject): TObjectNetworkTypes; Function GetNetworkTypesForObject(AID_Object: Integer): TObjectNetworkTypes; procedure DefineTracesWithExceedTwistedPair(AListID: Integer); function GetObjIcon(AIDObjectIcon: Integer; AGUIDObjIcon: String; AIconType: Integer; ADBMode: TDBKind = bkProjectManager): TBitmap; // вернет УГО объекта. если осутствует, то пытается определить из КАД объекта function GetObjIconForFigure(AIDList, AIDFigure, AIDObjectIcon: Integer; AGUIDObjIcon: String; AIconType: Integer): TBitmap; procedure AddObjectIconFromCADToDirectories(AIconName, AFileIconBMP, AFileIconBlk: String); function ChangeObjIconInCAD(AIDFigure: Integer; AGUIDObjIcon: String; AIconType: Integer): TObjectIconParams; function GetIconGUIDByIconID(AIconID: Integer): string; function GetFigureComponGraphicalImage(AIDFigure: Integer): TObjectList; //function GetConnectedTracesToConnetor(AIDList, AIDConnectorFigure: Integer): TIntList; function GetLineComponsFromTracesJoinedToPoint(AIDList, AIDConnectorFigure: Integer): TObject; // TSCSComponents function GetPointObjectConnectedTrunk(AListID, AFigureID: Integer): TCadCrossObject; function GetOldPointObjectConnectedTrunk(AListID, AFigureID: Integer): TCadCrossObject; function GetObjectIDsFromListBySameIcon(AListID, AFigureID: Integer; AGUIDObjectIcon: String): TIntList; procedure LoadMaskTemplatesToForm(AForm: TForm; AItemID, AItemType: Integer; AIsMaking: Boolean); procedure SaveMaskTemplatesFromForm(AForm: TForm; AItemID, AItemType: Integer; AForAllObjects, AIsMaking: Boolean); //procedure LoadMaskTemplatesFromFormToList(AList: TList); procedure CreateSpravochnikiInMasterNewList; procedure LoadFromFormToItemSpravochnik(AForm: TForm; AItemID, AItemTypeOfSprav, AItemType: Integer; AForAllObjects, AForSelected, AReIndexCompons, AReindexComponsInChangedTypes, AReindexAllPointCompons, AIsMaking: Boolean; ASprElements: TSprElements; ADataPointer: Pointer); procedure LoadFromFormToSpravochnik(AItemType: Integer; ASpravochnik: TObject; ASprElements: TSprElements); procedure LoadFromItemSpravochnikToForm(AForm: TForm; AItemID, AItemType: Integer; AIsMaking: Boolean; ASprElements: TSprElements); //procedure LoadSpravochnikTo function MakeEditProject(AMakeEdit: TMakeEdit; AIDProject: Integer; var AProjectParams: TProjectParams; ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; function GetNormsForCad(AListID: Integer): TList; function GetCurrentNormsForCAD(AListID: Integer): TObjectList; function GetOldNormsForCAD(AListID: Integer): TObjectList; procedure SetNormsToListFromCAD(AListID: Integer; ANorms: TObjectList); function UpdateNB(ADestBasePath: String = ''; AControlByBuildID: Boolean = false; AUpdaterPath: String = ''): Boolean; // Узнать не простая ли трасса - сп, мэ, магистральный переход function IsSpecialTrace(AListID, ATraceID, ATraceSCSID: Integer): Boolean; // Узнать не простая ли трасса - сп, мэ, магистральный переход function IsSpecialTraceFigure(AFigure: TOrthoLine): Boolean; function GetAllTraceIDsInCADByEndLines(AFirstLineListID, ALastLineListID, AFirstLineFigureID, ALastLineFigureID: Integer): TIntList; function GetFigureByListIDAndID(AListID, AFigureID: Integer): TFigure; function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; function GetPointObjectRelationsBetweenListDistr(AIDList: Integer): TObjectList; function GetListsIDRelatedToFigures(ACurrListID: Integer; AFiguresID: TIntList): TIntList; procedure SetStatusFilteredConnectedObjToCAD(AIDList: Integer); // UNDO REDO // Вернуть листы, проект - Вызов из CAD procedure UndoListInPM(aListID: Integer; aBasePath: string; AIsProject: Boolean; AListItemIndex, AListCount: Integer); // Удалить слепок листа проекта для отката - Вызов из CAD procedure DeleteUndoFromPM(aListID: Integer; aBasePath: string; AIsProject: Boolean); // Создать слепок листа для отката - Вызов из CAD //Tolik 18/07/2025 -- //function SavePMForUndo(aID: Integer; AIsProject: Boolean): String; function SavePMForUndo(aID: Integer; AIsProject: Boolean; a3D: Boolean = false): String; // // Создат undo слепок для проекта //Tolik 11/07/2025 -- //function SaveCurrProjectToUndoFiles: String; function SaveCurrProjectToUndoFiles(aFor3D: Boolean = false): String; // // Создат undo слепок для листа //Tolik 18/07/2025 -- //function SaveListToUndoFiles(AListID: Integer): String; function SaveListToUndoFiles(AListID: Integer; a3D: Boolean = false): String; // // Сохранит текущий проект в UNDO стек function SaveCurrProjectToUndoStack: String; // сохранит лист в UNDO стек function SaveListToUndoStack(AListID: Integer): String; // созранит список листов в UNDO стек procedure SaveListsToUndoStack(AListIDs: TIntList); // Администрирование пользователей function GetUserNameFromPM: String; function GetUserRightCaption(ARights: Integer): String; procedure LoginUserToProMan; procedure ShowPMUsers; procedure ShowCurrUserInfo; function GetSelectedFieldValuesFromcxTable(AFieldName: String; ATableView: TcxGridDBTableView): TStringList; function GetSelectedIDsFromcxTable(ATableView: TcxGridDBTableView): TIntList; function CreateComponInPMByType(ATrgObject: TObject; const ACompTypeSysName: String; AIsLine: Integer): TObject; function CreateHouseInPM(AListID: Integer): Integer; function CreateApproachInPM(AListID, AHouseID: Integer; var AApproachComponID: Integer): Integer; procedure DeleteComponInPM(AListID, AComponID: Integer; ACompon: TObject=nil); procedure SelectComponInPM(AListID, AComponID: Integer); function GetControlFromListByTag(AControls: TList; ATag: Integer): TControl; function GetControlScreenPt(aControl: TControl; aCorner: TAreaCornerType=ctTopLeft): TPoint; //Добавление количества портов и количество жил на порт procedure DefineImpotantProperty1;///Макс //добавление количества жил на кабель procedure DefineImpotantProperty2;///Макс //добавление размеры сторон на каб каналы procedure DefineImpotantProperty3;///Макс //добавление размеры сторон на каб каналы procedure DefineImpotantProperty4;///Макс procedure LoadCADFromFile(const AFileName: String); function CreatePDFObject(aOwner: TComponent; const aTitle:String; AFileName: string=''; aOutputStream: TStream=nil): TPDFDocument; procedure SetCADPageParamsToPDF(ACad: TForm; aPDFDoc: TPDFDocument; AIsSubstrate: Boolean); function GetClassPropList(AClass: TClass): TStringList; function GetPropertyObject(AObject: TObject; const APropName: String; AMinClass: TClass): TObject; function IsBoolTypeInfo(ATypeInfo: PTypeInfo): Boolean; function ObjectProps(AObject: TObject): TStringList; procedure ObjectPropsToForm(AObject: TObject; AForm: TForm; APropPrefix:string='f'); procedure ObjectPropsFromForm(AObject: TObject; AForm: TForm; APropPrefix:string='f'); procedure ObjectPropsToSCSObj(AObject: TObject; ASCSObj: TObject); procedure ObjectPropsToSCSChild(AObject: TObject; ASCSObj: TObject; AChildIsLine: Integer); procedure ObjectPropsFromSCSObj(AObject: TObject; ASCSObj: TObject); procedure ObjectPropsFromSCSChild(AObject: TObject; ASCSObj: TObject; AChildIsLine: Integer); procedure ObjectPropsToObj(ASrcObject, ATrgObject: TObject); procedure SetFormControlDisplayFormat(AForm: TForm); function KeyExistsInReg(ARootKey: DWORD; const AKey: String): Boolean; function IsOOInstalled: Boolean; function IsWordInstalled: Boolean; procedure OpenProgram(const prog, params: string); procedure ReloadProgram; procedure StreamToOLEStream(AStream: TStream; AOutOLEStream: TStream); procedure TerminateProgramm; procedure InitGlobalObjects; Procedure CheckForNewVersion(ver, build: string; aSelf: TComponent); // Tolik 10/09/2021 -- //const //udUpDownCaption = cudUpDownCaption; var ShowCheckBoxOnTemplateMarkForm: Boolean = false; GGlobalInternationalSettings: TInternationalSettings; GLocaleInternationalSettings: TInternationalSettings; GDatabaseName: string; GCreatedDMAIN : Boolean; GisLineCopingCompon: Integer; GID_CopingCompon: Integer; //GComplect: TComponData; GIDLastProject: Integer; GIDLastList: Integer; GIsLostConnect: Boolean = false; //GIDLastNBDir: Integer; GExistsSelectTrace: Boolean = false; //*** компоненты по умолчанию //GDefaultNoLineCompon: Integer; //GDefaultLineCompon: Integer; GSCSIni: TSCSIni; GNBSettings: TNBSettingRecord; //GAutoInsertingCompons: Boolean; // Tolik 28/08/2019 -- //GDragPrevTickCount : Cardinal; //GDragCurrTickCount : Cardinal; GDragPrevTickCount : DWord; GDragCurrTickCount : DWord; // GPrevDragNode: TTreeNode; GCanCopyComponToCAD: Boolean; GBaseBeginUpdateCount: Integer; GBaseUpdateHandling: Boolean = false; GLockConnectDisconnectCount: Integer = 0; GIsDublicatingCADObjects: Boolean = false; GLockDefineObjectParamsCount: Integer = 0; GFirstCursorNodeToExpand: TTreeNode; GHandleWindowForNodeToExpand: HWND; GHandleWindowForTreeViewScroll: HWND; GTreeViewWithNodeToExpand: TTreeView; GTreeViewToScrollOnDrag: TTreeView = nil; GTreeViewScrollType: TScrollType; //Tolik 28/0/2019 -- //GTreeViewLastRepaintTime: Cardinal; GTreeViewLastRepaintTime: DWord; // GCableCompTypes: TStringList = nil; GExceptionCount: Integer = 0; GTimerListToHandle: TList=nil; GSQLMTSignatures: TStringList; GCompTypeSysNameCables: TStringList; GCompTypeSysNameCableChannels: TStringList; GCompTypeSysNameComplexCompons: TStringList; GCompTypeSysNamePanels: TStringList; GCompTypeSysNameModules: TStringList; GPropSysNameInUOM: TStringList; GPropSysNameInUOM2: TStringList; GPropSysNameInUOM3: TStringList; GPropSysNameCalc: TStringList; // Расчетные свойства GPropRequired: TStringList; GPropRequiredIndexInSection: Integer; GPropRequiredIndexOutSection: Integer; GPropRequiredIndexPortCount: Integer; GPropRequiredIndexPortWireCount: Integer; GPropRequiredIndexWireCount: Integer; GPropRequiredIndexCableCanalElemetType: Integer; GPropRequiredIndexConduitSideDimensions: Integer; GPropRequiredIndexConduitElmentSideDimensions: Integer; GPropRequiredIndexConduitElmentSide1Dimensions: Integer; GPropRequiredIndexConduitElmentSide2Dimensions: Integer; GPropRequiredIndexConduitElmentSide3Dimensions: Integer; GPropRequiredIndexConduitElmentSide4Dimensions: Integer; GUniversalInterfaces: TStringList; GExecuteLog: TStringList; GExecuteLogPosStr: Integer = 0; GCurrProjUnitOfMeasure: Integer; GCanJoinInterfFemaleToFemale: Boolean = false; GCanExtendInterfPosInVirtualCompons: Boolean = true; {$IF Not Defined(FINAL_SCS)} GIsConnChildToTopCompon: Boolean = true; {$ELSE} //GIsConnChildToTopCompon: Boolean = false; GIsConnChildToTopCompon: Boolean = true; {$IFEND} // Свойства идущие от лайт свойства GUseComponTemplates: Boolean = true; // Использовать шаблоны компонентов GUseVisibleInterfaces: Boolean = true; // Использовать видимые интерфейсы GTemplateContCompl: Boolean = false; // Шаблоны могут иметь комплектуюш GUseSCSFunc: Boolean = true; //GMainFormHandle: HWND; //GAutoTraceConnectOrder: TAutoTraceConnectOrderType = ctPMOrder; //GAutoTraceOnePortToOne: Boolean = true; GUseVerticalTraces: Boolean = false; GDropObjByOneClick: Boolean = true; // Tolik 01/08/2019 размещать объекты в 1 клик (опционно, по "просьбам трудящихся") GShowAutoCreatedGuides: Boolean = False; // Tolik 26/03/2021 -- отображать автоматически созданные направляющие GStoreLastPaths: Boolean = false; // Tolik 01/08/2019 запоминать пути (опционно, по "просьбам трудящихся") GAutoScaleRasterImages: Boolean = True; // Tolik 09/08/2019 -- Масштабировать растровые изображения (подложки), // превышающие размеры листа //GCallElectricAutoTraceMaster: Boolean = False; // Tolik 03/03/2021 -- вызывать мастер автотрассировки электрики после отрисовки трасс электрическим кабелем GCallElectricAutoTraceMaster: Boolean = True; // Tolik 03/03/2021 -- вызывать мастер автотрассировки электрики после отрисовки трасс электрическим кабелем //Tolik 03/05/2017 GConnectTraceOnClickPoint: Boolean = False; // соединять трассы с поинтами в точке клика мышкой при ручном создании, // если объект и трасса находятся на одной высоте .... GMoveRouteToPointObject: Boolean = False; // подтягивать край трассы к УГО точечного объекта (или выравнять по нему) GAllowDropCableToRoute: Boolean = false; // разрешить дроп кабеля на страссы при перетаскивании из НБ //Tolik 09/08/2021 -- будет работать для компьютерных сетей (при соотв проверках) GAutoRouteCableAfterTraceCreation: boolean = True; // вызывать автотрассировку кабеля после автоматического создания трасс // Tolik 26/03/2024 -- автоматическое добавление сетевого оборудования в шкаф при трассировке кабеля для компьютерных сетей //GAutoAddNetworkEquipment : Boolean = False; {$IF Defined(SCS_PE)} GAutoAddNetworkEquipment : Boolean = True; {$ELSE} GAutoAddNetworkEquipment : Boolean = False; {$IFEND} // GSendInfo: Boolean = true; GProcCnt: Integer = 0; GTimerHintHandler: Integer = 0; GESHintWindow: TESHintWindow; GTimerESHintHandler: Integer=0; GTimerImgHintHandler: Integer=0; CanDeleteFromCAD: Boolean = false; GShowMessTextInAdmBuild: Boolean = True; GTestSingleBlock: TFigureGrpMod; GNeedReRaiseProperties: boolean = False; GLoadPCadBackGroundImage: Boolean = False; // Tolik 29/01/2020 -- признак того, что грузится растровое изображение на подложку Када GDropTracing: Boolean = false;// Tolik 11/11/2024 -- флажок сброса трассировки, если долго идет расчет пути implementation Uses U_Main, Unit_DM_SCS, U_Common, U_SCSClasses, U_SCSComponent, U_SCSInterfPath, U_BaseSettings, U_ChoiceConnectSide, U_ComponTypesMarkMask, U_InputBox, U_CaseForm, U_BaseUpdate, USCS_Main, U_MasterNewList, U_MasterNewListLite, U_Progress, U_Connect, U_Animate, U_CAD, U_ProtectionBase, U_Kalc, cxGridTableView, U_UsersEditor, U_UserInfo, U_ProtectionCommon, U_FilterConfigurator, U_InputRange, fplan, Types; Procedure CheckForNewVersion(ver, build: string; aSelf: TComponent); // Tolik 10/09/2021 -- var FreeBytesAvailableToCaller: TLargeInteger; FreeSize: TLargeInteger; TotalSize: TLargeInteger; Str: string; url_update: string; url_patch: string; url_download: string; nm: TIdHTTP; BytesTotal: integer; SHI : TShellExecuteInfo; tmp_strL: TStringList; run_str: string; upd_fld: string; iserror: boolean; SearchR: TSearchRec; Sres: integer; run_upd: boolean; SaveDS: char; SaveShortDateFormat: string; res_dlg: TModalResult; AddUrl: string; UpdStream: TMemoryStream; RespList: TStringList; Reg: TRegistry; begin AddUrl := '_ua'; {$IF DEFINED(SCS_RF)} AddUrl := '_rf'; {$IFEND} {$IF DEFINED(SCS_UKR)} AddUrl := '_ukr'; {$IFEND} {$IF DEFINED(SCS_PE)} AddUrl := '_pe'; {$IFEND} run_str := ''; url_download := ''; run_upd := false; tmp_strL := nil; Str := ExtractFileDrive(ExeDir); if GetDiskFreeSpaceEx(PChar(Str), FreeBytesAvailableToCaller, Totalsize, @FreeSize) then begin if FreeSize > 0 then begin try SaveDS := DateSeparator; SaveShortDateFormat := ShortDateFormat; DateSeparator := '.'; ShortDateFormat := 'dd.MM.yyyy'; nm := TIdHTTP.Create(aSelf); url_update := 'http://www.expertsoft.com.ua/scs/update/' + ver + '_' + build + AddUrl + '_update.html'; url_patch := 'http://www.expertsoft.com.ua/scs/update/' + ver + '_' + build + AddUrl + '_patch.html'; try RespList := TStringList.Create; UpdStream := TMemoryStream.Create; NM.Get(url_update, UpdStream); if UpdStream.Size > 0 then begin UpdStream.Position := 0; RespList.LoadFromStream(UpdStream); end; except on e: Exception do begin UpdStream.free; RespList.Free; exit; end; end; url_download := ''; if NM.ResponseCode = 200 then begin url_download := Trim(RespList.Text); //nm.Response.ResponseText //NM.Body; end; res_dlg := MessageDlg(UpdMsg1, mtConfirmation,[mbYes, mbCancel], 0); if (res_dlg = mrOk) or (res_dlg = mrYes) then begin end else url_download := ''; if url_download <> '' then begin BytesTotal := -1; isError := false; tmp_strL := TStringList.Create; tmp_strL.Text := url_download; if (tmp_strL.Count > 1) then begin url_download := tmp_strL[0]; end; tmp_strL.Delimiter := '/'; tmp_strL.DelimitedText := url_download; try upd_fld := ExeDir + '\updates\'; if not DirectoryExists(upd_fld) then CreateDir(upd_fld); if DirectoryExists(upd_fld) and (tmp_strL.Count > 0) then begin run_str := tmp_strL.Strings[tmp_strL.Count - 1]; end; UpdStream.free; RespList.Free; if run_str <> '' then begin UpdStream := TMemoryStream.Create; try NM.Get(url_download, UpdStream); if UpdStream.Size > 0 then begin BytesTotal := UpdStream.Size; UpdStream.Position := 0; UpdStream.SaveTofile(upd_fld + run_str); end; except on e: Exception do begin UpdStream.free; exit; end; end; UpdStream.free; //if NM.ReplyNumber = 200 then if NM.ResponseCode = 200 then begin //BytesTotal := nm.BytesTotal; end; if (BytesTotal > -1) then begin if (BytesTotal * 3000) > FreeSize then begin ShowMessage(UpdMsg2); exit; end; //check allready exist file and size try Sres:= FindFirst(upd_fld + run_str, 0, SearchR); if Sres = 0 then begin if SearchR.Size = BytesTotal then begin run_upd := true; BytesTotal := -2; end else begin DeleteFile(upd_fld + run_str); end; end else begin end; except ShowMessage(UpdMsg3 + #13#10 + upd_fld + run_str); end; try SysUtils.FindClose(SearchR); except end; end; if (BytesTotal > -1) then begin end else begin if not run_upd then isError := True; end; end else begin isError := True; end; if isError then begin ShowMessage(UpdMsg4 + #13#10 + url_download + #13#10 + UpdMsg5 + upd_fld); end else begin if run_upd then begin try try Reg := TRegistry.Create; Reg.RootKey := HKEY_CURRENT_USER; Reg.Openkey('Software',true); if not Reg.KeyExists('ExpertSoft') then Reg.CreateKey('ExpertSoft'); Reg.OpenKey('ExpertSoft', true); if not Reg.KeyExists('ExpertCad') then Reg.CreateKey('ExpertCad'); Reg.OpenKey('ExpertCad', true); Reg.WriteString('PathForUpdate', ExeDir); except on E: Exception do; end; finally Reg.CloseKey; Reg.Free; end; ZeroMemory(@SHI, sizeof(SHI)); SHI.cbSize := sizeof(SHI); SHI.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_NOCLOSEPROCESS; SHI.Wnd := Application.Handle; SHI.lpVerb := PChar('Open'); SHI.lpParameters := nil; SHI.lpDirectory := nil; SHI.lpFile := PChar(upd_fld + run_str); ShellExecuteEx(@SHI); exit; end; end; except on E: Exception do ShowMessage(E.Message); end; end; finally DateSeparator := SaveDS; ShortDateFormat := SaveShortDateFormat; if tmp_strL <> nil then tmp_strL.Free; nm.Free; end; end else begin ShowMessage(UpdMsg6); end; end else begin ShowMessage(UpdMsg7); end; end; function ABCToDec(AStrValue: String): Integer; var AbcLength: Integer; CharList: TStringList; CharNum: Integer; i: Integer; LookedCount: Integer; function PowerInt(ABase: Integer; AExponent: Integer): Integer; var i: Integer; begin Result := 1; for i := 0 to AExponent - 1 do Result := Result * ABase; end; begin Result := 0; // AbcLength = 26 // BA = 53 = 1 + 26*2 // ZZ = 702 = 26 + 26 * 26 = 26 + 26^2 // AAA = 703 = 1 + 26 + 26 * 26 = 1 + 26^1 + 26^2 // AAB = 704 = 2 + 26 + 26 * 26 = 2 + 26^1 + 26^2 // ABA = 729 = 1 + 26*2 + 26*26 = 1 + 26*2 + 26^2 // BBA = 1405 = 1 + 26*2 + 26*26*2 = 1 + 26*2 + 26^2*2 = (26^0)*1 + (26^1)*2 + (26^2)*3 // AAAA = 18279 = 1 + 26 + 26*26 + 26*26*26 = 1 + 26^1 + 26^2 + 26^3 AbcLength := Length(cnstAbsUP); CharList := TStringList.Create; for i := 1 to AbcLength do CharList.Add(cnstAbsUP[i]); // перебираем символы строки с конца LookedCount := 0; for i := Length(AStrValue) downto 1 do begin CharNum := CharList.IndexOf(AStrValue[i]); if CharNum <> -1 then begin CharNum := CharNum + 1; Result := Result + PowerInt(AbcLength, LookedCount) * CharNum; end; LookedCount := LookedCount + 1; end; CharList.Free; end; // Преобразует метры, сантиметры в миллиметры function ConvertUOMToMin(AUOM: Integer): Integer; begin Result := AUOM; if CheckIsTradUOM(AUOM) then Result := umInch else Result := umMillimetr; end; function ConvertUOMToSuppliesKind(AUOM: Integer): Integer; begin Result := AUOM; if CheckIsTradUOM(AUOM) then Result := umFoot else Result := umMetr; end; procedure GetMetricSettings; var LogFont: TLogFont; NonClientMetrics: TNonClientMetrics; SaveShowHint: Boolean; begin SaveShowHint := False; if Assigned(Application) then SaveShowHint := Application.ShowHint; try if Assigned(Application) then Application.ShowHint := False; if SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(LogFont), @LogFont, 0) then Screen.IconFont.Handle := CreateFontIndirect(LogFont) else Screen.IconFont.Handle := GetStockObject(SYSTEM_FONT); NonClientMetrics.cbSize := SizeOf(NonClientMetrics); if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then begin Screen.HintFont.Handle := CreateFontIndirect(NonClientMetrics.lfStatusFont); Screen.MenuFont.Handle := CreateFontIndirect(NonClientMetrics.lfMenuFont); end else begin Screen.HintFont.Size := 8; Screen.MenuFont.Handle := GetStockObject(SYSTEM_FONT); end; Screen.HintFont.Color := clInfoText; Screen.MenuFont.Color := clMenuText; finally if Assigned(Application) then Application.ShowHint := SaveShowHint; end; end; function FloatInUOM(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1): Double; var CurrUOMKoeff: Double; ResUOMKoeff: Double; function GetKoeffByUOM(AUOM: Integer): Double; begin Result := 1; case AUOM of umMillimetr: Result := 1; umSantimetr: Result := ummSantimetr; // 10 umMetr: Result := ummMetr; // 10000 umKiloMetr: Result := ummKiloMetr; umInch: Result := ummInch; umFoot: Result := ummFoot; umMile: Result := ummMile; end; // Возводим в степень if APower <> -1 then if Result <> 0 then Result := exp(ln(Result) * APower); end; begin Result := AValue; if ACurrUOM <> AResUOM then if AValue <> 0 then begin CurrUOMKoeff := GetKoeffByUOM(ACurrUOM); ResUOMKoeff := GetKoeffByUOM(AResUOM); Result := Result * (CurrUOMKoeff / ResUOMKoeff); end; end; function FloatInUOMSpec(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1): Double; var CurrUOMKoeff: Double; ResUOMKoeff: Double; function GetKoeffByUOM(AUOM: Integer): Double; begin Result := 1; case AUOM of umMillimetr: Result := 1; umSantimetr: Result := ummSantimetr; // 10 umMetr: Result := ummMetr; // 10000 umKiloMetr: Result := ummKiloMetr; umInch: Result := ummInch; umFoot: Result := ummFootSpec; umMile: Result := ummMile; end; // Возводим в степень if APower <> -1 then if Result <> 0 then Result := exp(ln(Result) * APower); end; begin Result := AValue; if ACurrUOM <> AResUOM then if AValue <> 0 then begin CurrUOMKoeff := GetKoeffByUOM(ACurrUOM); ResUOMKoeff := GetKoeffByUOM(AResUOM); Result := Result * (CurrUOMKoeff / ResUOMKoeff); end; end; function FloatInUOMStr(AValue: Double; ACurrUOM, AResUOM: Integer; APower: Integer=-1; AUOMCaption: Boolean=false): String; begin Result := FloatToStr(FloatInUOM(AValue, ACurrUOM, AResUOM, APower)); if AUOMCaption then begin Result := Result + ' '+ GetNameUOM(AResUOM, true, false); if (APower < -1) or (APower > 1) then Result := Result + IntToStr(APower); end; end; Function CheckSysNameInUOM(const ASysName: string): Boolean; begin Result := False; if GPropSysNameInUOM.IndexOf(ASysName) <> -1 then Result := True else begin if Pos('ZONE', ASysName) = Length(ASysName) - 3 then Result := True; end; end; procedure PropValueInUOM(var AValue: Double; const ASysName: string; ACurrUOM, AResUOM: Integer); var CurrUOMMin: Integer; ResUOMMin: Integer; begin if ASysName = pnExpenseForMetr then AValue := {RoundCP(}FloatInUOM(AValue, AResUOM, ACurrUOM){)} else //Tolik 03/11/2017 -- //if GPropSysNameInUOM.IndexOf(ASysName) <> -1 then if CheckSysNameInUOM(ASysName) then begin if (ACurrUOM = 3) and (AResUOM = 6) then AValue := FloatInUOMSpec(AValue, ACurrUOM, AResUOM) else AValue := {RoundCP(}FloatInUOM(AValue, ACurrUOM, AResUOM);{)} end else if (ASysName = pnOutDiametr) or (ASysName = pnInDiametr) then begin CurrUOMMin := ConvertUOMToMin(ACurrUOM); ResUOMMin := ConvertUOMToMin(AResUOM); AValue := FloatInUOM(AValue, CurrUOMMin, ResUOMMin); end else if (ASysName = pnOutSection) or (ASysName = pnInSection) then begin CurrUOMMin := ConvertUOMToMin(ACurrUOM); ResUOMMin := ConvertUOMToMin(AResUOM); AValue := FloatInUOM(AValue, CurrUOMMin, ResUOMMin, 2); end else if (GPropSysNameInUOM2.IndexOf(ASysName) <> -1) then AValue := FloatInUOM(AValue, ACurrUOM, AResUOM, 2) else if (GPropSysNameInUOM3.IndexOf(ASysName) <> -1) then AValue := FloatInUOM(AValue, ACurrUOM, AResUOM, 3); end; function PropValueToCaption(const AValue, ASysName, AIzm: string; AIDDataType, AUOM: Integer; AAllowIzm: Boolean): string; var PropDoubleVal: Double; Values: TStringList; ValIdx: Integer; begin Result := AValue; if ((AIDDataType = dtFloat) or (AIDDataType = dtInteger)) then begin PropDoubleVal := StrToFloatDef_My(AValue, 0); PropValueInUOM(PropDoubleVal, ASysName, umMetr, AUOM); Result := FloatToStr(RoundCP(PropDoubleVal)); end else if AIDDataType = dtDate then Result := DateToStr(StrToDateU(AValue)) else if AIDDataType = dtCompStateType then Result := GetCompStateTypeName(StrToInt(AValue)) else if AIDDataType = dtCableCanalElementType then Result := GetCableChannelElementName(StrToInt(AValue)) else if AIDDataType = dtBoolean then Result := BoolToStrL(IntToBool(StrToInt(AValue))) else if AIDDataType = dtConnectionKind then Result := GetTubeConnectKindName(StrToInt(AValue)) //else if AIDDataType = dtPlaneMaterialType then // Result := GetPlaneMaterialTypeName(StrToIntDef(AValue, 0)) else begin Values := TStringList.Create; FillPropValuesByDataType(Values, AIDDataType); ValIdx := IndexOfIDInStrings(StrToIntDef(AValue, 0), Values); if ValIdx <> -1 then Result := Values[ValIdx] else Result := AValue; FreeStringsObjects(Values, false); Values.Free; end; if AAllowIzm then Result := Result + ' '+ GetNameUOMForProperty(AIzm, ASysName, AUOM); end; function PropValToStr(AProp: PProperty): String; begin Result := AProp^.Value; if AProp^.IDDataType = dtFloat then Result := FloatToStrU(Round3(StrToFloatU(AProp^.Value))); end; function DecToABC(ADecValue: Integer): string; //const // AbcLength = 26; // AbcUP: array[0..AbcLength-1] of char = ('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','Z'); var CurrValue: Integer; ModRes: Integer; AbcLength: Integer; begin Result := ''; try AbcLength := Length(cnstAbsUP); CurrValue := ADecValue; while CurrValue > 0 do begin ModRes := CurrValue mod AbcLength; if ModRes > 0 then begin Result := cnstAbsUP[ModRes] + Result; CurrValue := CurrValue div AbcLength; end else begin Result := cnstAbsUP[AbcLength] + Result; if CurrValue = AbcLength then Break; //// BREAK //// CurrValue := CurrValue div AbcLength; CurrValue := CurrValue - 1; end; end; {CurrValue := ADecValue; while CurrValue > 0 do begin ModRes := CurrValue mod AbcLength; if ModRes > 0 then begin Result := AbcUP[ModRes-1] + Result; CurrValue := CurrValue div AbcLength; end else begin Result := AbcUP[AbcLength-1] + Result; if CurrValue = AbcLength then Break; //// BREAK //// CurrValue := CurrValue div AbcLength; CurrValue := CurrValue - 1; end; end;} except on E: Exception do AddExceptionToLogEx('DecToABC', E.Message); end; end; function DecToSN(ADecValue, ASN: Integer): TIntList; var CurrValue: Integer; ModRes: Integer; begin Result := TIntList.create; try CurrValue := ADecValue; while CurrValue > 0 do begin ModRes := CurrValue mod ASN; CurrValue := CurrValue div ASN; Result.Insert(0, ModRes); end; except on E: Exception do AddExceptionToLogEx('DecToSN', E.Message); end; end; function RoundX(Num: Extended; Dig: integer): Extended; const epsilon: Double = 0.000001; var Fakt: Extended; Vrem: Extended; pw: Extended; begin SetPrecisionMode(pmExtended); Set8087CW(Default8087CW); pw := Power(10, Dig); Fakt := Frac(Num); Fakt := pw * Fakt; Vrem := Frac(Fakt); Fakt := Int(Fakt); if (Vrem - 0.5) >= -epsilon then Fakt := Fakt + 1 else if (Vrem + 0.5) <= -epsilon then Fakt := Fakt - 1; Result := Int(Num) + Fakt/pw; end; function Round0(N: Extended): Extended; begin Result := RoundX(N, 0); end; function Round2(N: Extended): Extended; begin Result := RoundX(N, 2); end; function Round3(N: Extended): Extended; begin Result := RoundX(N, 3); end; function Round4(N: Extended): Extended; stdcall; begin Result := RoundX(N, 4); end; function RoundCP(N: Extended): Extended; begin Result := RoundX(N, FloatPrecision); end; function RoundUp(N: Extended): Integer; begin Result := Round(N); //if Abs(N - (N div 1)) > 0 then //if (N - (N div 1)) > 0 then if (N - Trunc(N)) <> 0 then Result := Round(N + 0.5); end; procedure SaveGlobalInternationalSettings; var Reg: TRegistry; begin {ZeroMemory(@GGlobalInternationalSettings, SizeOf(TInternationalSettings)); Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('\Control Panel\International',true) then begin GGlobalInternationalSettings.DecimalSeparator := Reg.ReadString('sDecimal'); GGlobalInternationalSettings.DateSeparator := Reg.ReadString('sDate'); GGlobalInternationalSettings.ShortDateFormat := Reg.ReadString('sShortDate'); GGlobalInternationalSettings.ThousandSeparator := Reg.ReadString('sThousand'); end; finally Reg.CloseKey; Reg.Free; end;} end; procedure SetCursors; begin // Для отчетов Screen.Cursors[crHandFingers] := LoadCursor(HInstance, 'CUR_HAND_FINGERS'); Screen.Cursors[crHandFist] := LoadCursor(HInstance, 'CUR_HAND_FIST'); end; procedure SetInternationalSettingsToRegistry(ASettings: TInternationalSettings); var Reg: TRegistry; begin {try Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('\Control Panel\International',true) then begin Reg.WriteString('sDecimal', ASettings.DecimalSeparator); Reg.WriteString('sDate', ASettings.DateSeparator); Reg.WriteString('sShortDate', ASettings.ShortDateFormat); Reg.WriteString('sThousand', ASettings.ThousandSeparator); end; finally Reg.CloseKey; Reg.Free; end; except on E: Exception do AddExceptionToLogEx('SetInternationalSettingsToRegistry', E.Message); end;} end; procedure SetLocaleInternationalSettings; begin (* // Сохраняем глобальные региональные настройки SaveGlobalInternationalSettings; Exit; ///// EXIT ///// ZeroMemory(@GLocaleInternationalSettings, SizeOf(TInternationalSettings)); GLocaleInternationalSettings.DecimalSeparator := ','; GLocaleInternationalSettings.DateSeparator := '.'; GLocaleInternationalSettings.ShortDateFormat := 'dd.MM.yyyy'; GLocaleInternationalSettings.ThousandSeparator := ' '; // Устанавливаем нужные региональные настройки в реестр SetInternationalSettingsToRegistry(GLocaleInternationalSettings); // Локальные региональные настройки в переменные программы DecimalSeparator := GLocaleInternationalSettings.DecimalSeparator[1]; DateSeparator := GLocaleInternationalSettings.DateSeparator[1]; ShortDateFormat := GLocaleInternationalSettings.ShortDateFormat; ThousandSeparator := GLocaleInternationalSettings.ThousandSeparator[1]; { CurrencyString := 'грн.'; CurrencyFormat := 3; NegCurrFormat := 8; CurrencyDecimals := 2; LongDateFormat := 'd MMMM yyyy'' р.'; TimeSeparator := ':'; TimeAMString := ''; TimePMString := ''; ShortTimeFormat := 'h:mm'; LongTimeFormat := 'h:mm:ss'; ListSeparator := ';'; } { if GLog = nil then GLog := TStringList.Create; GLog.Add('CurrencyString := '''+CurrencyString+''''); GLog.Add('CurrencyFormat := '+IntToStr(CurrencyFormat)); GLog.Add('NegCurrFormat := '+IntToStr(NegCurrFormat)); GLog.Add('ThousandSeparator := '''+ThousandSeparator+''''); GLog.Add('DecimalSeparator := '''+DecimalSeparator+''''); GLog.Add('CurrencyDecimals := '+IntToStr(CurrencyDecimals)); GLog.Add('DateSeparator := '''+DateSeparator+''''); GLog.Add('ShortDateFormat := '''+ShortDateFormat+''''); GLog.Add('LongDateFormat := '''+LongDateFormat+''''); GLog.Add('TimeSeparator := '''+TimeSeparator+''''); GLog.Add('TimeAMString := '''+TimeAMString+''''); GLog.Add('TimePMString := '''+TimePMString+''''); GLog.Add('ShortTimeFormat := '''+ShortTimeFormat+''''); GLog.Add('LongTimeFormat := '''+LongTimeFormat+''''); GLog.Add('ListSeparator := '''+ListSeparator+''''); } *) end; function StrToDateS(AString: string): TDate; begin Result := 0; try Result := StrToDateU(AString); except end; end; function DateToStrU(const DateTime: TDateTime): string; var SavedDateSeparator: Char; SavedShortDateFormat: String; begin //Tolik Result := ''; // SavedDateSeparator := DateSeparator; DateSeparator := '.'; SavedShortDateFormat := ShortDateFormat; ShortDateFormat := 'dd.MM.yyyy'; try Result := DateToStr(DateTime); finally DateSeparator := SavedDateSeparator; ShortDateFormat := SavedShortDateFormat; end; end; function DateTimeToStrU(const DateTime: TDateTime): string; var SavedDateSeparator: Char; SavedShortDateFormat: String; begin //Tolik Result := ''; // SavedDateSeparator := DateSeparator; DateSeparator := '.'; SavedShortDateFormat := ShortDateFormat; ShortDateFormat := 'dd.MM.yyyy'; try Result := DateTimeToStr(DateTime); finally DateSeparator := SavedDateSeparator; ShortDateFormat := SavedShortDateFormat; end; end; function FloatNoZero(AValue, ANoZeroVal: Double): Double; begin Result := AValue; if Result = 0 then Result := ANoZeroVal; end; function FloatToStrU(Value: Extended): string; var SavedDecimalSeparator: Char; SavedThousandSeparator: Char; begin //Tolik Result := ''; // SavedDecimalSeparator := DecimalSeparator; DecimalSeparator := ','; SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := FloatToStr(Value); finally DecimalSeparator := SavedDecimalSeparator; ThousandSeparator := SavedThousandSeparator; end; end; function FloatToStrFU(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string; var SavedDecimalSeparator: Char; SavedThousandSeparator: Char; begin //Tolik Result := ''; // на всякий // SavedDecimalSeparator := DecimalSeparator; DecimalSeparator := ','; SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := FloatToStrF(Value, Format, Precision, Digits); finally DecimalSeparator := SavedDecimalSeparator; ThousandSeparator := SavedThousandSeparator; end; end; function FormatFloatU(AFormat: String; AFloat: Extended): String; var SavedDecimalSeparator: Char; begin SavedDecimalSeparator := DecimalSeparator; DecimalSeparator := ','; try Result := FormatFloat(AFormat, AFloat); finally DecimalSeparator := SavedDecimalSeparator; end; end; {function IntToStrU(Value: Integer): string; var SavedThousandSeparator: Char; begin SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := IntToStr(Value); finally ThousandSeparator := SavedThousandSeparator; end; end; } function StrToDateU(const S: String): TDateTime; var SavedDateSeparator: Char; SavedShortDateFormat: String; begin SavedDateSeparator := DateSeparator; DateSeparator := '.'; SavedShortDateFormat := ShortDateFormat; ShortDateFormat := 'dd.MM.yyyy'; try Result := StrToDate(S); finally DateSeparator := SavedDateSeparator; ShortDateFormat := SavedShortDateFormat; end; end; function StrToFloatU(const S: String): Extended; var SavedDecimalSeparator: Char; SavedThousandSeparator: Char; begin SavedDecimalSeparator := DecimalSeparator; DecimalSeparator := ','; SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := StrToFloat_My(S); finally DecimalSeparator := SavedDecimalSeparator; ThousandSeparator := SavedThousandSeparator; end; end; function StrToFloatDefU(const S: string; const Default: Extended): Extended; var SavedDecimalSeparator: Char; SavedThousandSeparator: Char; begin SavedDecimalSeparator := DecimalSeparator; DecimalSeparator := ','; SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := StrToFloatDef_My(S, Default); finally DecimalSeparator := SavedDecimalSeparator; ThousandSeparator := SavedThousandSeparator; end; end; function StrToMinLen(const aStr: String; aMinLen: Integer): String; begin Result := aStr; while Length(Result) < aMinLen do Result := '0'+Result; end; function HmsStr(const aSepartor: string): string; begin Result := IntToStrF(HourOf(Time), 2) +aSepartor+ IntToStrF(MinuteOf(Time), 2) +aSepartor+ IntToStrF(SecondOf(Time), 2); end; function YMDStr(const aSepartor: string): String; begin Result := IntToStrF(YearOf(Date), 4) +aSepartor+ IntToStrF(MonthOf(Date), 2) +aSepartor+ IntToStrF(DayOf(Date), 2); end; {function StrToIntU(const S: string): Integer; var SavedThousandSeparator: Char; begin SavedThousandSeparator := ThousandSeparator; ThousandSeparator := #160; try Result := StrToInt(S); finally ThousandSeparator := SavedThousandSeparator; end; end;} function CreateGUID: String; var GUID: TGUID; S: String; begin Result := ''; if CoCreateGuid(GUID) = s_OK then Result := GUIDToString(GUID); end; procedure CorrectMaskKeyPress(var Key: Char); begin if (Key = '.') or (Key = ',') then if Key <> DecimalSeparator then Key := DecimalSeparator; //#0; end; procedure EmptyProcedure; begin end; function AddGUIDIDToStrings(const AName, AGUID: String; AID: integer; AStrings: TStrings; AIndex: Integer = -1): TObject; var ComboItemObject: TIDGuidObject; begin ComboItemObject := TIDGuidObject.Create; ComboItemObject.ID := AID; //FN(AIDfld).AsInteger; ComboItemObject.GUID := AGUID; if AIndex = -1 then AStrings.AddObject(AName, ComboItemObject) else AStrings.InsertObject(AIndex, AName, ComboItemObject); Result := ComboItemObject; end; procedure AddGUIDIDToStringsFromMT(AStrings: TStrings; AMemTable: TkbmMemTable; const ANameFld, AGUIDFld: String; AClear: Boolean=true); var //BookmarkStr: String; BookmarkStr: TBookMark; begin if AClear then RemoveGUIDIDFromStrings(AStrings, true); AMemTable.DisableControls; //BookmarkStr := AMemTable.Bookmark; BookmarkStr := AMemTable.GetBookmark; try AMemTable.First; while Not AMemTable.Eof do begin AddGUIDIDToStrings(AMemTable.FieldByName(ANameFld).AsString, AMemTable.FieldByName(AGUIDFld).AsString, 0, AStrings); AMemTable.Next; end; finally //AMemTable.Bookmark := BookmarkStr; AMemTable.GotoBookmark(BookmarkStr); AMemTable.FreeBookmark(BookmarkStr); AMemTable.EnableControls; end; end; function IndexOfGUIDInStrings(const AGUID: String; AStrings: TStrings): Integer; var i: integer; StrObject: TObject; begin Result := -1; for i := 0 to AStrings.Count - 1 do begin StrObject := AStrings.Objects[i]; if StrObject is TIDGuidObject then if TIDGuidObject(StrObject).GUID = AGUID then begin Result := i; Break; //// BREAK //// end; end; end; function GetGUIDFromStrings(AStrings: TStrings; AIndex: Integer): String; begin Result := ''; if (AIndex <> -1) and (AIndex <= (AStrings.Count - 1)) then if TObject(AStrings.Objects[AIndex]) is TIDGuidObject then Result := TIDGuidObject(AStrings.Objects[AIndex]).GUID; end; function GetGUIDFromStrings(AStrings: TStrings; const AName: String): String; begin Result := GetGUIDFromStrings(AStrings, AStrings.IndexOf(AName)); end; function GetIDFromStrings(AStrings: TStrings; AIndex: Integer): Integer; begin Result := 0; if AIndex <= (AStrings.Count - 1) then if TObject(AStrings.Objects[AIndex]) is TIDGuidObject then Result := TIDGuidObject(AStrings.Objects[AIndex]).ID; end; function GetNameFromStringsByGUID(const AGUID: String; AStrings: TStrings): String; var Index: Integer; begin Result := ''; Index := IndexOfGUIDInStrings(AGUID, AStrings); if Index <> -1 then Result := AStrings[Index]; end; procedure RemoveGUIDIDFromStrings(AStrings: TStrings; ACanClear: Boolean=false); var i: Integer; StrObject: TObject; begin try for i := 0 to AStrings.Count - 1 do begin StrObject := AStrings.Objects[i]; if StrObject is TIDGuidObject then begin AStrings.Objects[i] := nil; TIDGuidObject(StrObject).Free; end; end; if ACanClear then AStrings.Clear; except on E: Exception do AddExceptionToLogEx('RemoveGUIDIDFromStrings', E.Message); end; end; function CorrectStrToCSV(AStr: String): String; begin Result := ''; try while Pos(';',AStr) > 0 do AStr[Pos(';',AStr)] := ' '; while Pos(#10,AStr) > 0 do AStr[Pos(#10,AStr)] := ' '; while Pos(#13,AStr) > 0 do AStr[Pos(#13,AStr)] := ' '; Result := AStr; except end; end; function CorrectStrToFloat(const AStr: String): String; var i: Integer; TempStr: String; LookedSeparator: Boolean; Sign: string; begin Result := AStr; TempStr := AStr; i := 1; // Знак Sign := ''; if (Length(TempStr) > 0) and (TempStr[1] = '-') then Sign := '-'; LookedSeparator := false; while i <= Length(TempStr) do begin if TempStr[i] in ['0'..'9', ',', '.'] then begin if TempStr[i] = '.' then TempStr[i] := ','; if TempStr[i] = ',' then begin if LookedSeparator then begin Delete(TempStr, i, 1); Continue; //// CONTINUE //// end; LookedSeparator := true; end; Inc(i); end else Delete(TempStr, i, 1); end; if TempStr = '' then TempStr := '0' else if TempStr[1] in [',', '.'] then TempStr := '0' + TempStr else if TempStr[Length(TempStr)] in [',', '.'] then TempStr := TempStr + '0'; Result := Sign + TempStr; end; function IsEmptyVal(AVal: String): Boolean; begin Result := (AVal='') or (AVal='0'); end; function StrCanBeFloat(AStr: String): Boolean; var Len: Integer; i: Integer; FloatCharCount: Integer; NoFloatCharCount: Integer; begin Result := false; FloatCharCount := 0; NoFloatCharCount := 0; Len := Length(AStr); for i := 1 to Len do begin if (AStr[i] in ['0'..'9']) or (AStr[i] = ',') then Inc(FloatCharCount) else begin Inc(NoFloatCharCount); Break; ///// BREAK ///// end; end; if (FloatCharCount > 0) and (NoFloatCharCount = 0) then Result := true; end; function StrAsEmptyToFloat(AStr: String): Double; begin Result := 0; if AStr <> '' then Result := StrToFloat_My(AStr); end; function GetDimensionsMask: String; begin //*** Обозначение элементов маски // \d - эквивалент 0-9 // \d+ - неогрениченная длина числа // ? - говорит, что предыдущей аргумент может не вводиться // (, \d+)? - возможно запятая с чмслом неограниченной длины // [01] - вводится одно из перечисляемых значений в скобках // (\d | [A-F] | [a-f])+ - пример маски для ввода шестнадцатеричных чисел (| - типа ИЛИ) //Result := '[\d]+x[\d]+'; //Result := '\d+?,?\d+x\d+,?\d+'; Result := '\d+ (, \d+)? x \d+ (, \d+)?'; end; function GetDisplayFormat(const NameBrief: String): String; begin Result := GetDisplayFormatForFloat +' '+ NameBrief +'''.'' '; end; function GetDisplayFormatForFloat: String; begin {$IF Defined(SCS_PE)} Result := ',0.00'; {$ELSE} Result := ',0.000'; {$IFEND} end; function GetDisplayFormatForFloatByPrecision(APrecision: Integer): String; var i: Integer; begin Result := ',0.'; if APrecision > 0 then begin for i := 0 to APrecision - 1 do Result := Result + '0'; end else Result := Result + '0'; end; function GetFloatMask(aPrecision: Integer=2): String; begin Result := '(-)?\d+\' +DecimalSeparator+ '?\d{1,'+IntToStr(aPrecision)+'}' //'(-)?\d+' +DecimalSeparator+ '\d?\d?'; end; function GetFloatMaskUnsig(aPrecision: Integer=2): String; begin Result := '\d+\' +DecimalSeparator+ '?\d{1,'+IntToStr(aPrecision)+'}' //'\d+' +DecimalSeparator+ '\d?\d?'; end; function GetZeroConditionAsNull(AFieldName: String; ACondition: Integer): String; begin Result := ''; if ACondition = 0 then Result := AFieldName+' is null' else Result := AFieldName+' = '''+IntToStr(ACondition)+''''; end; function GetPrefixCountByType(const AText, APrefix: String; ACount: Integer; APrefixType: TPrefixCountType): String; begin Result := ''; if ACount > 1 then begin case APrefixType of pctBefore: Result := IntToStr(ACount)+ APrefix + AText; pctAfter: Result := AText +APrefix+ IntToStr(ACount); end; end else if ACount = 1 then Result := AText; end; function GetStringsFromStr(const AStr: string; ASeparator: Char; AIncludeEmptySections: Boolean): TStringList; var i: Integer; LenStr: Integer; BuffStr: String; begin Result := TStringList.Create; BuffStr := ''; LenStr := Length(AStr); for i := 1 to LenStr do begin if AStr[i] <> ASeparator then BuffStr := BuffStr + AStr[i]; if (AStr[i] = ASeparator) or (i=LenStr) then if (BuffStr <> '') or AIncludeEmptySections then begin Result.Add(BuffStr); BuffStr := ''; // если последний символ - разделитель, то добавляем пустую строку if AIncludeEmptySections then if (AStr[i] = ASeparator) and (i=LenStr) then Result.Add(''); end; end; end; function SplitString(const AStr, ASeparator: string; AIncludeEmptySections: Boolean): TStringList; var i: Integer; LenStr: Integer; BuffStr: String; SepLookIdx: Integer; SepBuff: String; IsFullSep: Boolean; begin Result := TStringList.Create; BuffStr := ''; LenStr := Length(AStr); SepLookIdx := 1; SepBuff := ''; for i := 1 to LenStr do begin IsFullSep := false; if AStr[i] = ASeparator[SepLookIdx] then begin if SepLookIdx = Length(ASeparator) then begin IsFullSep := true; SepLookIdx := 1; SepBuff := ''; end else begin SepBuff := SepBuff + AStr[i]; Inc(SepLookIdx); Continue; //// CONTINUE //// end; end else begin // Сброс буФера сплитера if SepLookIdx > 1 then begin BuffStr := BuffStr + SepBuff; SepLookIdx := 1; SepBuff := ''; end; end; if Not IsFullSep then BuffStr := BuffStr + AStr[i]; if IsFullSep or (i=LenStr) then if (BuffStr <> '') or AIncludeEmptySections then begin Result.Add(BuffStr); BuffStr := ''; // если последний символ - разделитель, то добавляем пустую строку if AIncludeEmptySections then if IsFullSep and (i=LenStr) then Result.Add(''); end; end; end; function ConcatStrWithDefis(AStr1, AStr2: String; ASpaces: Integer = 0): String; var Defis: String; Spaces: String; begin Result := ''; if AStr1 <> '' then begin Spaces := DupStr(' ', ASpaces); Defis := Spaces + '-' + Spaces; Result := AStr1 + Defis; end; Result := Result + AStr2; end; //##### Убрать строки, которых нет в списке AStringsToCmp ##### function RemoveNoAssignedStrings(ADestStringList, AStringsToCmp: TStringList): Boolean; var i: Integer; begin //Tolik //Result := true; Result := False; // i := 0; while i <= ADestStringList.Count - 1 do begin if AStringsToCmp.IndexOf(ADestStringList[i]) = -1 then begin ADestStringList.Delete(i); Result := true; end else Inc(i); end; end; procedure SetGUIDToStrings(AStrings: TStrings; const AGUID, AName: String); var Obj: TObject; Idx: Integer; begin Idx := AStrings.IndexOf(AName); Obj := nil; if Idx <> -1 then Obj := AStrings.Objects[Idx]; if Obj <> nil then TIDGuidObject(Obj).GUID := AGUID; end; function CheckFileInUse(FileName: String): Boolean; var HFileRes: HFILE; F: TFileStream; begin {Result := False; try F := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive); try Result := true; finally F.Free; end; except Result := false; end; } Result := False; if not FileExists(FileName) then Exit; HFileRes := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); Result := (HFileRes = INVALID_HANDLE_VALUE); if not Result then CloseHandle(HFileRes); end; function CompareFiles(Filename1,FileName2:string): Boolean; { Сравнение файлов возвращает номер несовпадающего байта, (байты отсчитываются с 1)или: 0 - не найдено отличий, -1 - ошибка файла 1 -2 - ошибка файла 2 -3 - другие ошибки } const Buf_Size=16384; var F1,F2:TFileStream; Size1, Size2: Integer; i: longint; ByteRead1, ByteRead2: Byte; begin Result := false; try F1:=TFileStream.Create(FileName1,fmShareDenyNone); except exit; end; try F2:=TFileStream.Create(FileName2,fmShareDenyNone); except F1.Free; exit; end; try Size1 := F1.Size; Size2 := F2.Size; if Size1 = Size2 then begin Result := true; for i := 0 to Size1 - 1 do begin F1.ReadBuffer(ByteRead1, SizeOf(ByteRead1)); F2.ReadBuffer(ByteRead2, SizeOf(ByteRead2)); if ByteRead1 <> ByteRead2 then begin Result := false; Break; //// BREAK //// end; end; end; except end; F1.Free; F2.Free; end; function CompareFilesStrings(AFileName1, AFileName2: string): Boolean; var Strings1: TStringList; Strings2: TStringList; i: Integer; begin Result := false; Strings1 := TStringList.Create; Strings2 := TStringList.Create; try Strings1.LoadFromFile(AFileName1); Strings2.LoadFromFile(AFileName2); if Strings1.Count = Strings2.Count then begin Result := true; for i := 0 to Strings1.Count - 1 do if Strings2.IndexOf(Strings1[i]) = -1 then begin Result := false; //Break; //// BREAK //// end; end; finally Strings1.Free; Strings2.Free; end; end; function CheckIsIPName(AName: string): Boolean; var PointCount: Integer; SectCount: Integer; LastWasPoint: Boolean; LastWasDigit: Boolean; IsNoIP: Boolean; i: Integer; ch: Char; begin Result := false; PointCount := 0; SectCount := 0; LastWasPoint := false; LastWasDigit := false; IsNoIP := false; for i := 1 to Length(AName) do begin ch := AName[i]; if (ch >= '0') or (ch <= '9') then begin if Not LastWasDigit then Inc(SectCount); LastWasDigit := true; LastWasPoint := false; end else if ch = '.' then begin if LastWasPoint or Not LastWasDigit then begin IsNoIP := true; Break; //// BREAK //// end else Inc(PointCount); LastWasPoint := true; LastWasDigit := false; end else begin IsNoIP := true; Break; //// BREAK //// end; end; if Not IsNoIP then if (SectCount > 0) and (PointCount > 0) then Result := true; end; function CopyFileToByName(ASrcDBName, ANewDBName: String): Boolean; begin Result := CopyFileTo(ASrcDBName, ANewDBName); end; function GetCharCountFromStr(AChar: Char; AStr: String): Integer; var i: Integer; begin Result := 0; for i := 1 to Length(AStr) do if AStr[i] = AChar then Inc(Result); end; function GetFileOwner(FileName: string; var Domain, Username: string): Boolean; // Tolik 04/04/2019 -- не юзается ниде.... var SecDescr: PSecurityDescriptor; SizeNeeded, SizeNeeded2: DWORD; OwnerSID: PSID; OwnerDefault: BOOL; OwnerName, DomainName: PChar; OwnerType: SID_NAME_USE; begin GetFileOwner := False; GetMem(SecDescr, 1024); GetMem(OwnerSID, SizeOf(PSID)); GetMem(OwnerName, 1024); GetMem(DomainName, 1024); try if not GetFileSecurity(PChar(FileName), OWNER_SECURITY_INFORMATION, SecDescr, 1024, SizeNeeded) then Exit; if not GetSecurityDescriptorOwner(SecDescr, OwnerSID, OwnerDefault) then Exit; SizeNeeded := 1024; SizeNeeded2 := 1024; if not LookupAccountSID(nil, OwnerSID, OwnerName, SizeNeeded, DomainName, SizeNeeded2, OwnerType) then Exit; Domain := DomainName; Username := OwnerName; finally FreeMem(SecDescr); FreeMem(OwnerName); FreeMem(DomainName); end; GetFileOwner := True; end; function BrowseDialog(const aTitle, ADefFolder: string; const aFlag: integer = BIF_RETURNONLYFSDIRS): string; const BIF_NEWDIALOGSTYLE = $00000040; BIF_UAHINT = $00000100; var lpItemID: PItemIDList; BrowseInfo: TBrowseInfo; DisplayName: array [0..MAX_PATH] of char; TempPath: array [0..MAX_PATH] of char; procedure CallBackAll(Wnd: HWnd; uMsg: Uint; lParam, lpData: LPARAM); stdcall; var S: string; TempPath : array[0..MAX_PATH] of char; DriveChar: string; DriveType: integer; begin //S := 'Выберите папку для установки программы'; //SendMessage(Wnd, BFFM_SetStatusText, 0, LongInt(@S[1])); if uMsg = BFFM_INITIALIZED then SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData)); if uMsg = BFFM_SELCHANGED then begin //SHGetPathFromIDList(PItemIDList(lParam), TempPath); {if Not SHGetPathFromIDList(PItemIDList(lParam), TempPath) then SendMessage(wnd, BFFM_ENABLEOK, 0, 0) else begin try DriveChar := ExtractFileDrive(TempPath); DriveType := GetDriveType(PChar(DriveChar + '\')); if (DriveType = 3) or ((DriveType = 4) And (Pos('\\', TempPath) <> 0)) then SendMessage(wnd, BFFM_ENABLEOK, 0, 1) else SendMessage(wnd, BFFM_ENABLEOK, 0, 0); except SendMessage(wnd, BFFM_ENABLEOK, 0, 0); end; end;} end; end; begin Result := ''; FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); with BrowseInfo do begin hwndOwner := Application.Handle; //PChar(@DisplayName) := ExtractSaveDir; //Copy(ExtractSaveDir, 1, Length(ExtractSaveDir)); //DisplayName := 'qwerty'; pszDisplayName := @DisplayName; //pszDisplayName := PChar(ExtractSaveDir); lpszTitle := PChar(aTitle); ulFlags := aFlag or BIF_EDITBOX or BIF_NEWDIALOGSTYLE or BIF_UAHINT; end; BrowseInfo.lpfn := @CallBackAll; if ADefFolder <> '' then BrowseInfo.lparam := Integer(PChar(ADefFolder)); lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); Result := TempPath; GlobalFreePtr(lpItemID); end; end; function IsNT(var Value: Boolean): Boolean; var Ver: TOSVersionInfo; BRes: Boolean; begin Ver.dwOSVersionInfoSize := SizeOf(TOSVersionInfo); BRes := GetVersionEx(Ver); if not BRes then //Проверка begin Result := False; //Информация не получена Exit; //уходим end else Result := True; //Информация получена case Ver.dwPlatformId of //определяемся VER_PLATFORM_WIN32_NT : Value := True; //Windows NT - подходит VER_PLATFORM_WIN32_WINDOWS : Value := False; //Windows 9x-Me - подходит VER_PLATFORM_WIN32s : Result := False //Windows 3.x - не подходит end; end; function GetLocalPath(Server: string; NetDrive: string): string; var i:Integer; FLibHandle : THandle; ShareNT : PShareInfo2Array; //<= Перемеменные entriesread,totalentries:DWORD; //<= для Windows NT Share : array [0..512] of TShareInfo50; //<= Перемеменные Share2: array [0..512] of TShareInfo298; pcEntriesRead,pcTotalAvail:Word; //<= для Windows 9x-Me OS: Boolean; Res: integer; ServName: PWideChar; LocPath: string; SERVER_INFO_100: TSERVER_INFO_100; NetShareEnumNT: function ( servername:PWChar; level:DWORD; bufptr:Pointer; prefmaxlen:DWORD; entriesread, totalentries, resume_handle:LPDWORD): DWORD; stdcall; NetShareEnum:function ( pszServer : PChar; sLevel : Cardinal; pbBuffer : Pchar; cbBuffer : Cardinal; pcEntriesRead, pcTotalAvail: Pointer):DWORD; stdcall; begin result := ''; if not IsNT(OS) then exit; //Определяем тип системы // Получить тип сервера //NetServerGetInfo( Server, 100, @SERVER_INFO_100); if OS then begin //Код для NT FLibHandle := LoadLibrary('NETAPI32.DLL'); //Загружаем библиотеку if FLibHandle = 0 then Exit; //Связываем функцию @NetShareEnumNT := GetProcAddress(FLibHandle,'NetShareEnum'); if not Assigned(NetShareEnumNT) then //Проверка begin FreeLibrary(FLibHandle); Exit; end; ShareNT := nil; //Очищаем указатель на массив структур //Вызов функции GetMem(ServName, length(Server) * 2 + 1); StringToWideChar(Server, ServName, length(Server) * 2 + 1); Res := NetShareEnumNT(ServName, 2, @ShareNT, DWORD(-1), @entriesread, @totalentries, nil); FreeMem(ServName); if Res <> 0 then begin //Если вызов неудачен выгружаем библиотеку FreeLibrary(FLibHandle); Exit; end; if entriesread > 0 then begin //Обработка результатов NetDrive := AnsiUpperCase(NetDrive); try for i:= 0 to entriesread - 1 do begin LocPath := String(ShareNT^[i].shi2_netname); LocPath := AnsiUpperCase(LocPath); if NetDrive = LocPath then result := String(ShareNT^[i].shi2_path); end; except end; end end else begin //Код для 9х-Ме if length(server) >= 2 then begin if (server[1] <> '\') and (server[2] <> '\') then server := '\\' + server; end; FLibHandle := LoadLibrary('SVRAPI.DLL'); //Загружаем библиотеку if FLibHandle = 0 then Exit; //Связываем функцию @NetShareEnum := GetProcAddress(FLibHandle,'NetShareEnum'); if not Assigned(NetShareEnum) then //Проверка begin FreeLibrary(FLibHandle); Exit; end; //Вызов функции Res := NetShareEnum(PChar(Server), 50, @Share, SizeOf(Share), @pcEntriesRead, @pcTotalAvail); if Res <> 0 then begin Res := NetShareEnum(PChar(Server), 2, @Share2, SizeOf(Share2), @pcEntriesRead, @pcTotalAvail); if Res <> 0 then begin //Если вызов неудачен выгружаем библиотеку FreeLibrary(FLibHandle); Exit; end; if pcEntriesRead > 0 then //Обработка результатов begin NetDrive := AnsiUpperCase(NetDrive); try for i:= 0 to entriesread - 1 do begin LocPath := String(Share2[i].shi2_netname); LocPath := AnsiUpperCase(LocPath); if NetDrive = LocPath then result := String(Share2[i].shi2_path); end; except end; end; FreeLibrary(FLibHandle); //Не забываем выгрузить библиотеку exit; end; if pcEntriesRead > 0 then //Обработка результатов begin NetDrive := AnsiUpperCase(NetDrive); try for i:= 0 to entriesread - 1 do begin LocPath := String(Share[i].shi50_netname); LocPath := AnsiUpperCase(LocPath); if NetDrive = LocPath then result := String(Share[i].shi50_path); end; except end; end; end; FreeLibrary(FLibHandle); //Не забываем выгрузить библиотеку end; function GetFullRemotePath(APath: String): String; var TempPath: String; NetServer: string; NetFolder: string; PathTmp: string; begin Result := APath; TempPath := APath; if (length(APath) > 1) {and (DirectoryExists(APath))} then begin if (pos('\\', TempPath) = 1) {and (DirectoryExists(TempPath))} then begin try PathTmp := ''; NetServer := copy(TempPath, 3, length(TempPath)); NetFolder := copy(NetServer, pos('\', NetServer) + 1, length(NetServer)); NetServer := copy(NetServer, 1, pos('\', NetServer) - 1); if pos('\', NetFolder) <> 0 then begin PathTmp := copy(NetFolder, pos('\', NetFolder) + 1, length(NetFolder)); NetFolder := copy(NetFolder, 1, pos('\', NetFolder) - 1); end; NetFolder := GetLocalPath(NetServer, NetFolder); NetFolder := NetFolder; if NetFolder[length(NetFolder)] <> '\' then NetFolder := NetFolder + '\'; Result := NetServer + ':' + NetFolder + PathTmp; if Result[length(Result)] <> '\' then Result := Result + '\'; except end; end else begin try Result := copy(TempPath, 1, length(TempPath)); if Result[length(Result)] <> '\' then Result := Result + '\'; except end; end; end end; function BrowseDialogRemote(AHandle: THandle; ADefFolder, ATitle: String): String; var TitleName : string; BrowseInfo : TBrowseInfo; // ISh: IShellFolder; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; Buff: PChar; PIDL: PItemIDList; NetServer: string; NetFolder: string; sr: TSearchRec; FileAttrs: Integer; PFileInfo: PSHFileInfo; SizePFInfo: integer; PathTmp: string; FullPath: string; TempStr: string; i: integer; FileN: string; lpItemID : PItemIDList; BaseFolder: String; procedure CallBackAll(Wnd: HWnd; uMsg: Uint; lParam, lpData: LPARAM); stdcall; var S: string; TempPath : array[0..MAX_PATH] of char; DriveChar: string; DriveType: integer; begin // S := 'Выберите папку для установки программы'; // SendMessage(Wnd, BFFM_SetStatusText, 0, LongInt(@S[1])); if uMsg = BFFM_INITIALIZED then SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData)); if uMsg = BFFM_SELCHANGED then begin if Not SHGetPathFromIDList(PItemIDList(lParam), TempPath) then SendMessage(wnd, BFFM_ENABLEOK, 0, 0) else begin try DriveChar := ExtractFileDrive(TempPath); DriveType := GetDriveType(PChar(DriveChar + '\')); if (DriveType = 3) or ((DriveType = 4) And (Pos('\\', TempPath) <> 0)) then SendMessage(wnd, BFFM_ENABLEOK, 0, 1) else SendMessage(wnd, BFFM_ENABLEOK, 0, 0); except SendMessage(wnd, BFFM_ENABLEOK, 0, 0); end; end; end; end; begin //Tolik Result := '';//на всякий // BaseFolder := ADefFolder; TempPath := ''; try // SHGetSpecialFolderLocation(Handle, CSIDL_DRIVES, PIDL); // TitleName := 'Please specify a directory'; PIDL := nil; TitleName := ATitle; FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := AHandle; BrowseInfo.pszDisplayName := @DisplayName; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; BrowseInfo.pidlRoot := PIDL; BrowseInfo.lpfn := @CallBackAll; if ADefFolder <> '' then begin //BrowseInfo.lparam := Integer(PChar(copy(ADefFolder, 2, length(ADefFolder) - 1))); //BrowseInfo.lparam := Integer(PChar(copy(ADefFolder, 3, length(ADefFolder) - 2))); BrowseInfo.lparam := Integer(PChar(ADefFolder)); end; lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); GlobalFreePtr(lpItemID); end; except end; Result := GetFullRemotePath(TempPath); end; function FilePathToURL(const AUrl: string): string; {var Buffer: string; BufferSize: DWORD; begin Result := ''; BufferSize := Length('file:///' + FilePath + #0); SetLength(Buffer, BufferSize); ExtractUrlFileName if UrlCreateFromPath(PChar(FilePath), PChar(Buffer), @BufferSize, 0) = S_OK then Result := Buffer;} var Index: Integer; begin Result := ''; for Index := 1 to Length(AUrl) do begin if AUrl[Index] = '\' then Result := Result + '/' else begin case AUrl[Index] of 'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.': Result := Result + AUrl[Index]; ' ' : Result := Result + '%20'; else Result := Result + '%' + IntToHex(Ord(AUrl[Index]), 2); end; end; end; end; function FindComputers(xxx: PNetResource; AStringList: TStringList=nil): TStringList; type PNRArr = ^TNRArr; TNRArr = array[0..59] of TNetResource; var x: PNRArr; tnr: TNetResource; I: integer; EntrReq, SizeReq, twx: THandle; WSName: string; ErrCode: Word; List: TStringList; begin Result := AStringList; List := AStringList; if AStringList = nil then begin Result := TStringList.Create; List := Result; end; ErrCode := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_CONTAINER, xxx, twx); if ErrCode = ERROR_NO_NETWORK then Exit; if ErrCode = NO_ERROR then begin New(x); EntrReq := 1; SizeReq := SizeOf(TNetResource) * 59; while (twx <> 0) and (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do begin for i := 0 to EntrReq - 1 do begin Move(x^[i], tnr, SizeOf(tnr)); case tnr.dwDisplayType of RESOURCEDISPLAYTYPE_SERVER: begin if tnr.lpRemoteName <> '' then WSName := tnr.lpRemoteName else WSName := tnr.lpComment; List.Add(copy(WSName, 3, length(WSName) - 2)); //list.Add(WSName); end; else FindComputers(@tnr, list); end; end; end; Dispose(x); WNetCloseEnum(twx); end; end; procedure OpenURL(const AURL: String); begin ShellExecute(0, 'open', PChar(AURL), nil, nil, SW_SHOW); end; // Не работает в Vista и Win7, вместо этой юзай BrowseComputer function ShowServerDialog(AHandle: THandle): string; var ServerBrowseDialogA0: TServerBrowseDialogA0; LANMAN_DLL: DWORD; buffer: array[0..1024] of char; bLoadLib: Boolean; begin Result := ''; LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL'); bLoadLib := false; if LANMAN_DLL = 0 then begin LANMAN_DLL := LoadLibrary('NTLANMAN.DLL'); bLoadLib := True; end; if LANMAN_DLL <> 0 then begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0'); DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil); ServerBrowseDialogA0(AHandle, @buffer, 1024); if buffer[0] = '\' then begin Result := buffer; end; if bLoadLib then FreeLibrary(LANMAN_DLL); end; end; function BrowseComputer(ADialogTitle: String=''; ADefComputer: string=''; bNewStyle: boolean=false): String; const BIF_USENEWUI = 28; var BrowseInfo: TBrowseInfo; ItemIDList: PItemIDList; ComputerName: array[0..MAX_PATH] of Char; Title: string; WindowList: Pointer; ShellMalloc: IMalloc; IsOk: Boolean; procedure CallBackAll(Wnd: HWnd; uMsg: Uint; lParam, lpData: LPARAM); stdcall; var S: string; TempPath : array[0..MAX_PATH] of char; DriveChar: string; DriveType: integer; begin // Выделить комп из параметра ADefComputer if uMsg = BFFM_INITIALIZED then SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData)); if uMsg = BFFM_SELCHANGED then begin // Если не сетевая папка, то разрешаем кнопку ОК if Not SHGetPathFromIDList(PItemIDList(lParam), TempPath) then SendMessage(wnd, BFFM_ENABLEOK, 0, 1) else SendMessage(wnd, BFFM_ENABLEOK, 0, 0); end; end; begin Result := ''; IsOk := false; if Failed( SHGetSpecialFolderLocation( Application.Handle, CSIDL_NETWORK, ItemIDList ) ) then raise Exception.Create( 'Unable open browse computer dialog' ); try if ADialogTitle = '' then ADialogTitle := cComputerSelection; FillChar( BrowseInfo, SizeOf( BrowseInfo ), 0 ); BrowseInfo.hwndOwner := Application.Handle; BrowseInfo.pidlRoot := ItemIDList; BrowseInfo.pszDisplayName := ComputerName; Title := ADialogTitle; BrowseInfo.lpszTitle := PChar( Pointer( Title ) ); if bNewStyle then BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER or BIF_USENEWUI else BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER; //BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_DONTGOBELOWDOMAIN; //BrowseInfo.ulFlags := BrowseInfo.ulFlags or BIF_RETURNONLYFSDIRS; BrowseInfo.lpfn := @CallBackAll; if ADefComputer <> '' then BrowseInfo.lparam := Integer(PChar(ADefComputer)); WindowList := DisableTaskWindows( 0 ); try IsOk := SHBrowseForFolder( BrowseInfo ) <> nil; finally EnableTaskWindows( WindowList ); end; if IsOk then Result := ComputerName; finally if Succeeded( SHGetMalloc( ShellMalloc ) ) then ShellMalloc.Free( ItemIDList ); end; end; {function BrowseNewDirName(aTitle, aDirPath, aDefNewDirName: string): string; var SaveDialog: TSaveDialog; //tbInfo: TTBButtonInfo; CloseQueryEvent: TCloseQueryEvent; ShowEvent: TNotifyEvent; ProcAddr: Pointer; LabelText: string; procedure SaveDialogCanClose(Sender: TObject; var CanClose: Boolean); var i: Integer; begin for i := 0 to TSaveDialog(Sender).Files.Count - 1 do begin if DirectoryExists(TSaveDialog(Sender).Files[i]) then begin MessageModal(cDirWithName+' "'+ExtractFileName(TSaveDialog(Sender).Files[i])+'" '+cNowExists+'.', TSaveDialog(Sender).Title, MB_ICONINFORMATION or MB_OK); CanClose := false; Break; ///// BREAK ///// end; end; end; procedure SaveDialogShow(Sender: TObject); const LB_FILETYPES_ID = 1089; // "File types:" label LB_FILENAME_ID = 1090; // "File name:" label LB_DRIVES_ID = 1091; // "Look in:" label CB_FILETYPES_ID = 1136; var hOpenDialog: HWND; i: Integer; begin hOpenDialog := GetParent(TSaveDialog(Sender).Handle); SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_FILENAME_ID, Longint(PChar('Имя папки'))); SendMessage(hOpenDialog, CDM_HIDECONTROL, LB_FILETYPES_ID, 0); SendMessage(hOpenDialog, CDM_HIDECONTROL, CB_FILETYPES_ID, 0); end; begin Result := ''; SaveDialog := TSaveDialog.Create(nil); SaveDialog.Title := aTitle; SaveDialog.FileName := aDefNewDirName; SaveDialog.InitialDir := aDirPath; SaveDialog.Options := SaveDialog.Options + [ofNoNetworkButton]; //SaveDialog.FileEditStyle CloseQueryEvent := nil; ProcAddr := @SaveDialogCanClose; Pointer(@CloseQueryEvent) := ProcAddr; SaveDialog.OnCanClose := CloseQueryEvent; Pointer(@ShowEvent) := @SaveDialogShow; SaveDialog.OnShow := ShowEvent; //Wnd := FindWindowEx(GetParent(SaveDialog.Handle), 0, '', nil); // if Wnd <> 0 then // begin // LabelText := '111111'; // SendMessage(Wnd, WM_SETTEXT, 0, Integer(@LabelText)); // end; // while Wnd <> 0 do // begin // Break; //// BREAK //// // end; if SaveDialog.Execute then Result := SaveDialog.FileName; FreeAndNil(SaveDialog); end; } function AddCreateDirToPath(const APath, ADirName: string): String; var PathLength: Integer; begin Result := ''; PathLength := Length(APath); if PathLength > 0 then begin if APath[PathLength] = '\' then Result := APath + ADirName else Result := APath + '\' + ADirName; //if Not DirectoryExists(Result) then // if Not CreateDir(Result) then // Result := ''; if Not DefineDir(Result) then Result := ''; end; end; function CheckIsLicalPath(const APath: string): Boolean; var ServerName: String; LocalPath: String; begin Result := true; ExtractServerName(APath, ServerName, LocalPath); if ServerName <> '' then Result := false; end; // Tolik 31/07/2019 -- старая закомменчена - см. ниже {function CheckStrInFilePos(AFileName, AString: String; AFilePos: Integer): Boolean; var FileStream: TFileStream; FileSize: Integer; i: Integer; CurrByte: Byte; AnsiStr: AnsiString; begin Result := false; AnsiStr := AnsiString(aString); if FileExists(AFileName) then begin FileStream := TFileStream.Create(AFileName, fmOpenRead); try FileSize := FileStream.Size; if FileSize >= (AFilePos + Length(AnsiStr)) then begin Result := true; if AFilePos > 0 then FileStream.Seek(AFilePos, soFromCurrent); //for i := 1 to Length(AString) do for i := 1 to Length(AnsiStr) do begin FileStream.ReadBuffer(CurrByte, SizeOf(CurrByte)); //if CurrByte <> Ord(AString[i]) then if CurrByte <> Ord(AnsiStr[i]) then begin Result := false; Break; //// BREAK //// end; end; end; finally FileStream.Free; end; end; end; } function CheckStrInFilePos(AFileName, AString: String; AFilePos: Integer): Boolean; var FileStream: TFileStream; FileSize: Integer; i: Integer; CurrByte: Byte; //Tolik -- for Debug s: AnsiString; FilePos, CurrFPos: Integer; // begin Result := false; if FileExists(AFileName) then begin FileStream := TFileStream.Create(AFileName, fmOpenRead); try FileSize := FileStream.Size; if FileSize >= (AFilePos + Length(AString)) then begin Result := true; if AFilePos > 0 then FileStream.Seek(AFilePos, soFromCurrent); //FilePos := Filestream.Position; for i := 1 to Length(AString) do begin FileStream.ReadBuffer(CurrByte, SizeOf(CurrByte)); if CurrByte <> Ord(AString[i]) then begin Result := false; Break; //// BREAK //// end; end; {Filestream.Position := FilePos; s := ''; for i := 0 to 13 do begin FileStream.ReadBuffer(CurrByte, SizeOf(CurrByte)); s := s + CurrByte; end; s := '';} end; finally FileStream.Free; end; end; end; function CheckOneStrInFilePos(AFileName: String; AStringList: TStringList; AFilePos: Integer): Boolean; var i: Integer; begin Result := false; for i := 0 to AStringList.Count - 1 do if CheckStrInFilePos(AFileName, AStringList[i], AFilePos) then begin Result := true; Break; //// BREAK //// end; end; function ConverPathToNix(APath: String): String; var ServerName: String; LocalPath: String; PosOfColon: Integer; i: Integer; begin Result := APath; try ExtractServerName(APath, ServerName, LocalPath); // Удаляем имя диска из пути PosOfColon := Pos(':', LocalPath); if PosOfColon <> 0 then Delete(LocalPath, 1, PosOfColon); // заменить слеши for i := 1 to Length(LocalPath) do begin if LocalPath[i] = '\' then LocalPath[i] := '/'; end; Result := ServerName + ':' + LocalPath; except on E: Exception do AddExceptionToLogEx('ConverPathToNix', E.Message); end; end; function DefineDir(const APath: String): Boolean; begin Result := true; if Not DirectoryExists(APath) then if Not CreateDir(APath) then begin Result := False; //raise Exception.Create(cSCSComponent_Msg11); end; end; function ExpandPath(const Path: string): string; var Dir, Drive, name: string; i, Count: Integer; Dirs: {TStringList; //:} array [0..127] of string; Buffer: array [0..MAX_PATH - 1] of Char; FName: PChar; FD: WIN32_FIND_DATA; HDir: THandle; NxtFile: Boolean; begin Result := ''; SetString(Dir, Buffer, GetFullPathName(PChar(Path), SizeOf(Buffer), Buffer, FName)); Drive := ExtractFileDrive(Dir); Count := 0; for i := Low(Dirs) to High(Dirs) do begin if (Length(Dir) = 3) or (Length(Dir) = Length(Drive)) then Break; name := ExtractFileName(Dir); Dir := ExtractFileDir(Dir); if name <> '' then begin Dirs[Count] := name; Inc(Count); end; end; if Count > 0 then Dir := Drive; name := UpperCase(Dir); for i := Count - 1 downto 0 do begin Dir := Concat(Dir, '\', Dirs[i]); HDir := FindFirstFile(PChar(Dir), FD); if HDir = INVALID_HANDLE_VALUE then Exit; try NxtFile := FindNextFile(HDir, FD); finally Windows.FindClose(HDir); end; if NxtFile then Exit; if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then Exit; name := Concat(name, '\', FD.cFileName); end; Result := name; end; function ExtractDefDirByCategoryType(ADirCategoryType: Integer): string; var CategoryName: String; begin Result := ''; CategoryName := ''; case ADirCategoryType of dctProjs: CategoryName := sdProjects; dctCompons: CategoryName := sdComponents; dctOtherSettings: CategoryName := sdSettings; dctFilters: CategoryName := sdFilters; dctBackgLayers: CategoryName := sdBackgroundLayers; dctArchPlans: CategoryName := sdArchPlans; dctDXF: CategoryName := sdDXF; dctPictures: CategoryName := sdPictures; dctStamps: CategoryName := sdStamps; end; if CategoryName <> '' then Result := ExtractSaveDirForCategory(CategoryName) else begin if ADirCategoryType = dctTemp then Result := GetDefaultTempPath; end; end; function ExtractDirByCategoryTypeDefault(ADirCategoryType: Integer): string; // Tolik begin Result := ExtractDefDirByCategoryType(ADirCategoryType); end; function ExtractDirByCategoryType(ADirCategoryType: Integer): string; var //CategoryName: String; DefDir: String; begin Result := ''; DefDir := ExtractDefDirByCategoryType(ADirCategoryType); if DefDir <> '' then Result := ReadEnvironmentDir(ADirCategoryType, DefDir) else Result := ExtractSaveDirSimple; end; function ExtractDirName(const APath: String): String; var path: String; begin path := ExcludeTrailingPathDelimiter(APath); Result := ExtractFileName(ExcludeTrailingPathDelimiter(APath)); end; function ExtractFileNameOnly(const AFileName: String): String; var Ext: String; begin Result := AFileName; Result := ExtractFileName(AFileName); Ext := ExtractFileExt(AFileName); SetLength(Result, Length(Result) - Length(Ext)); end; function ExtractFilePathOnly(const AFileName: String): String; begin Result := ExtractFilePath(AFileName) + ExtractFileNameOnly(AFileName); end; function ExtractFirstDirName(APath: String): String; var SymbIndex: Integer; i: Integer; CanBreak: Boolean; begin Result := APath; try // Удалить все от начала до двоеточья SymbIndex := Pos(':', Result); if SymbIndex <> 0 then Delete(Result, 1, SymbIndex); // Удалить слеши в начале i := 1; CanBreak := false; while i <= Length(Result) do begin if (Result[i] = '\') or (Result[i] = '/') or (Result[i] = ':') then begin Delete(Result, 1, i); CanBreak := true; end else if CanBreak then Break //// BREAK //// else Inc(i); end; {// Удалить слеш и все что после него i := 1; while i <= Length(Result) do begin if (Result[i] = '\') or (Result[i] = '/') then begin Delete(Result, i, Length(Result)-i + 1); Break; //// BREAK //// end; Inc(i); end; } except on E: Exception do AddExceptionToLogEx('ExtractFirstDirName', E.Message); end; end; //Tolik 04/04/2019 function ExtractMyDocDir: String; const BuffSize = 1024; var Buffer: PChar; //array[0..1023] of Char; begin Result := ''; Buffer := nil; GetMem(Buffer, (BuffSize + 1)*2); SHGetSpecialFolderPath(0, Buffer, CSIDL_PERSONAL, true); SetString(Result, Buffer, GetPCharLength(Buffer)); FreeMem(Buffer); end; { function ExtractMyDocDir: String; const BuffSize = 1024; var Buffer: PChar; //array[0..1023] of Char; begin Result := ''; Buffer := nil; GetMem(Buffer, BuffSize); SHGetSpecialFolderPath(0, Buffer, CSIDL_PERSONAL, true); SetString(Result, Buffer, GetPCharLength(Buffer)); FreeMem(Buffer); end; } function ExtractSaveDirForCategory(const ACategoryName: string): string; begin Result := ExtractSaveDirSimple; Result := AddCreateDirToPath(Result, ACategoryName); end; function ExtractSaveDirSimple: String; const BuffSize = 1024; var Buffer: PChar; //array[0..1023] of Char; begin Result := ''; {//06.04.2009 Result := ExtractFileDir(Application.ExeName); Result := Result +'\'+ dnSave; if Not DirectoryExists(Result) then if Not CreateDir(Result) then begin Result := ExtractFileDir(Application.ExeName); Exit; ///// EXIT ///// end; } { Buffer := nil; GetMem(Buffer, BuffSize); SHGetSpecialFolderPath(0, Buffer, CSIDL_PERSONAL, true); SetString(Result, Buffer, GetPCharLength(Buffer)); FreeMem(Buffer);} {$IF Defined(FLASH_SCS) or Defined(ES_GRAPH_SC)} Result := AddCreateDirToPath(ExtractFileDir(Application.ExeName), dnSave); {$ELSE} {Result := ExtractMyDocDir; if Result <> '' then begin Result := Result + '\' + FileNameCorrect(ApplicationName); if Not DirectoryExists(Result) then CreateDir(Result); end;} Result := AddCreateDirToPath(ExtractMyDocDir, FileNameCorrect(ApplicationName)); {$IFEND} end; function ExtractSaveDir(AProjDirName: string = ''): String; var CurrDir: String; ProjDir: String; begin Result := ''; {CurrDir := ExtractFileDir(Application.ExeName); CurrDir := CurrDir +'\'+ dnSave; if Not DirectoryExists(CurrDir) then if Not CreateDir(CurrDir) then begin Result := ExtractFileDir(Application.ExeName); Exit; ///// EXIT ///// end;} CurrDir := ExtractSaveProjectsDir; //ExtractSaveDirSimple; if DirectoryExists(CurrDir) then begin Result := CurrDir; ProjDir := AProjDirName; if ProjDir = '' then if Assigned(F_ProjMan) and Assigned(F_ProjMan.GSCSBase) then if Assigned(F_ProjMan.GSCSBase.CurrProject) then if F_ProjMan.GSCSBase.CurrProject.Active then begin ProjDir := F_ProjMan.GSCSBase.CurrProject.Name + ' ' + IntToStr(F_ProjMan.GSCSBase.CurrProject.MarkID); end; if ProjDir <> '' then begin ProjDir := FileNameCorrect(ProjDir); ProjDir := CurrDir+'\'+ProjDir; //if Not DirectoryExists(ProjDir) then // CreateDir(ProjDir); DefineDir(ProjDir); if DirectoryExists(ProjDir) then Result := ProjDir; end; end; end; function ExtractSaveProjectsDir: string; begin //Result := ExtractSaveDirForCategory(sdProjects); Result := ExtractDirByCategoryType(dctProjs); end; function ExtractSaveSettingsDir: string; //var // SaveDirPath: string; begin {Result := ''; SaveDirPath := ExtractSaveDirSimple; if SaveDirPath <> '' then begin Result := SaveDirPath + '\' + sdSettings; //dnSettings; if Not DirectoryExists(Result) then CreateDir(Result); end;} Result := ExtractDirByCategoryType(dctOtherSettings); end; procedure ExtractServerName(const AFileName: String; var AServerName, ALocalPath: String); var i: Integer; TotalColonCount: Integer; //общщее количество двоеточий CurrColonCount: Integer; //текущее количество двоеточий begin AServerName := ''; ALocalPath := ''; TotalColonCount := GetCharCountFromStr(':', AFileName); if pos(':/', AFileName) >= 1 then begin TotalColonCount := 2; end; //*** Если нет двоеточий, или одно, то это локальный путь if TotalColonCount <= 1 then ALocalPath := AFileName else //*** Если 2 двоеточий, то это сетевой путь if TotalColonCount = 2 then begin CurrColonCount := 0; for i := 1 to Length(AFileName) do begin if AFileName[i] = ':' then begin Inc(CurrColonCount); //*** пропускаеи 1- двоеточие - граница между именем сервера и локальным путем if CurrColonCount = 1 then Continue; //// CONTINUE //// end; if CurrColonCount = 0 then AServerName := AServerName + AFileName[i] else ALocalPath := ALocalPath + AFileName[i]; end; end; end; function ExtractSCSTempDir: String; begin //Result := ExtractFileDir(ParamStr(0)) + '\' + dnTemp+ '\'; Result := GetAnsiTempPath + dnSCS + '\'; //if Not DirectoryExists(Result) then // CreateDir(Result); DefineDir(Result); end; //рихтуем имена файлов от кракозябликов function FileNameCorrect(AFileName: string): string; begin Result := ''; try while Pos('?',AFileName) > 0 do AFileName[Pos('?',AFileName)] := ' '; while Pos('*',AFileName) > 0 do AFileName[Pos('*',AFileName)] := ' '; while Pos('\',AFileName) > 0 do AFileName[Pos('\',AFileName)] := ' '; while Pos('/',AFileName) > 0 do AFileName[Pos('/',AFileName)] := ' '; while Pos('.',AFileName) > 0 do AFileName[Pos('.',AFileName)] := ' '; while Pos('"',AFileName) > 0 do AFileName[Pos('"',AFileName)] := ' '; while Pos('''',AFileName) > 0 do AFileName[Pos('''',AFileName)] := ' '; while Pos('`', AFileName) > 0 do AFileName[Pos('`', AFileName)] := ' '; while Pos(':', AFileName) > 0 do AFileName[Pos(':', AFileName)] := ' '; Result := AFileName; except end; end; function GetAnsiTempPath: String; //08.09.2011 const //08.09.2011 BuffSize = 1024; //08.09.2011 var //08.09.2011 Buffer: PChar; //array[0..1023] of Char; var Error: Boolean; begin Result := ''; Error := false; //08.09.2011 GetMem(Buffer, BuffSize); //08.09.2011 GetTempPath(BuffSize, Buffer); //08.09.2011 SetString(Result, Buffer, GetPCharLength(Buffer)); //08.09.2011 FreeMem(Buffer); if GSCSIni.Environments.TempDir <> '' then begin Result := IncludeTrailingBackslash(GSCSIni.Environments.TempDir) + dnSCS + '\'; if Not ForceDirectories(Result) then Error := true; end else begin Result := GetDefaultTempPath + dnSCS + '\'; if Not DefineDir(Result) then Error := true; end; if Error then AddExceptionToLog(cSCSComponent_Msg22_8 +' '+Result+' .'+ cCauseFailFileAccess, true); end; // Tolik 17/05/2019 -- на всякий... "по науке" написал...старая закомменчена - см ниже function GetDefaultTempPath: String; var Buffer: array[0..MAX_PATH] of Char; begin GetTempPath(MAX_PATH, @Buffer); result := StrPas(Buffer); end; { function GetDefaultTempPath: String; var //Buffer: PChar; //array[0..1023] of Char; Bufferp: PWideChar; //array[0..1023] of Char; BuffSize: Dword; //Buffer: PAnsiChar; //array[0..1023] of Char; //str1: AnsiString; res: integer; begin BuffSize := 1024; GetMem(Bufferp, (BuffSize + 1) * 2); //GetTempPathA(BuffSize, Buffer); //str1 := copy(Buffer, 1, Length(Buffer)); //result := string(str1); res := GetTempPathW(BuffSize, Bufferp); SetString(Result, Bufferp, GetPCharLength(Bufferp)); FreeMem(Bufferp); end; } function GetFileContents(const aFilePath: String): String; var StringList: TStringList; begin StringList := TStringList.Create; StringList.LoadFromFile(aFilePath); Result := StringList.Text; FreeAndNil(StringList); end; // Tolik 04/04/2019 -- function GetFileFullPathTmp(const AFilePath: string): String; var Buffer: PWideChar; FileName: PChar; BuffSize: DWord; begin BuffSize := 1024; GetMem(Buffer, (BuffSize + 1) * 2); GetFullPathName(PChar(AFilePath), BuffSize, Buffer, FileName); SetString(Result, Buffer, GetPCharLength(Buffer)); FreeMem(Buffer); end; { function GetFileFullPathTmp(const AFilePath: string): String; const BuffSize = 1024; var //Buffer : array[0..BuffSize] of Char; Buffer: PChar; FileName: PChar; begin GetMem(Buffer, BuffSize); GetFullPathName(PChar(AFilePath), BuffSize, Buffer, FileName); SetString(Result, Buffer, GetPCharLength(Buffer)); FreeMem(Buffer); end; } function GetFileSizeByName(AFileName: String): Integer; begin Result := FileSizeByName(AFileName); end; function GetUniqueFileName(const APrefix, AExtension: String): String; var LengthStr: Integer; i: Integer; begin Result := FileNameCorrect(CreateGUID); LengthStr := Length(Result); i := 1; while i <= LengthStr do begin if Result[i] in ['{', '}', '-'] then begin Delete(Result, i, 1); Dec(LengthStr); end else Inc(i); end; if APrefix <> '' then Result := APrefix + Result; if AExtension <> '' then Result := Result + '.' + AExtension; end; function GetDialogFilter(const AExtensionDescription, AExtension: String): String; var FullExtName: String; begin //FullExtName := '*.'+AExtension; FullExtName := '*'; if (Length(AExtension) > 0) and (AExtension[1] <> '.') then FullExtName := FullExtName + '.'; FullExtName := FullExtName + AExtension; Result := AExtensionDescription+' ('+FullExtName+')|'+FullExtName; end; function GetExtensionDescription(const AExt: String): String; var Ext: String; begin Result := ''; Ext := AExt; if (Length(Ext)>0) and (Ext[1] = '.') then Ext := copy(Ext, 2, Length(Ext)-1); if Ext = enDoc then Result := cexdDoc else if Ext = enOdt then Result := cexdOdt; end; function GetPCharLength(APChar: PChar): Integer; var i: Integer; ch: Char; begin i := -1; repeat Inc(i); ch := APChar[i]; until ch = #0; Result := i; end; function GetFullFilePath(InputName: string): string; var Root, Net: Boolean; InPath, CurP, BegP: PChar; CurItem, CurPath, OutPath: string; RootGuard: SmallInt; FindHandle: Cardinal; FindData: WIN32_FIND_DATA; FileName: String; begin OutPath:= InputName; InPath:= PChar(ExtractFilePath(InputName)); FileName := ExtractFileName(InputName); Root:= True; Net:= False; RootGuard:= 0; CurP:= InPath; while CurP^<>#0 do begin BegP:= CurP; while (CurP^<>'\') and (CurP^<>#0) do CurP := CharNext(CurP); SetString(CurItem, BegP, CurP - BegP); if CurItem='' then CurPath:= CurPath+'\' else begin CurPath:= CurPath+CurItem; if Root then begin OutPath := CurPath; CurPath := CurPath+'\'; end;{if Root then} end;{if CurItem='' then CurPath:= CurPath+'\' else} if (CurPath='\\') or (CurPath='\') then Net:= True; if Root then begin if Net then begin RootGuard:= -1; Net:= False; end;{if Net then} Inc(RootGuard); if RootGuard>0 then Root:= False; end{if Root then} else begin FindHandle:= FindFirstFile(PChar(CurPath), FindData); OutPath:= OutPath+'\'+FindData.cFileName; Windows.FindClose(FindHandle); CurPath:= CurPath+'\'; end;{if Root then ... else} CurP := CharNext(CurP); end;{while CurP^ <> #0 do} Result:= OutPath; if FileName <> '' then Result:= Result + '\'+ FileName; end; function GetShortFilePath(const FileName: string): string; var buffer: array[0..MAX_PATH-1] of char; begin SetString(Result, buffer, GetShortPathName( pchar(FileName), buffer, MAX_PATH-1)); end; // удаляет из начала нули, дефисы (даже если перед ним есть один символ) function CutBeginZeroDefisInArticle(const AArtNo: String): String; begin Result := AArtNo; if (Length(Result) > 1) and (Result[2] = '-') then begin delete(Result, 1, 2); end; while Length(Result) > 0 do begin case Result[1] of '0', '-': delete(Result, 1, 1); else begin Break; //// BREAK //// end; end; end; end; function CmpFloatByPrecision(AVal1, AVal2: Double; APrecision: Integer): Boolean; begin Result := Abs(AVal1 - AVal2) < GetDeltaOneByPrecision(APrecision); end; function CmpFloatByCP(AVal1, AVal2: Double): Boolean; begin Result := CmpFloatByPrecision(AVal1, AVal2, FloatPrecision); end; function CmpRecords(AAddrRec1, AAddrRec2, ASize1, ASize2: Integer): Boolean; var Addr1, Addr2: Integer; CurrPtr1, CurrPtr2: Pointer; RecSize1, RecSize2: Word; i: integer; begin Result := true; RecSize1 := ASize1; //SizeOf(ARec1); RecSize2 := ASize2; //SizeOf(ARec2); //*** Размеры структур не равны if RecSize1 <> RecSize2 then begin Result := false; Exit; ///// EXIT ///// end; Addr1 := AAddrRec1; //Integer(@ARec1); Addr2 := AAddrRec2; //Integer(@ARec2); for i := 0 to RecSize1 - 1 do begin CurrPtr1 := Ptr(Addr1 + i); CurrPtr2 := Ptr(Addr2 + i); if Byte(CurrPtr1^) <> Byte(CurrPtr2^) then begin Result := false; Break; ///// BREAK ///// end; end; end; function CompareInt(const AVal1, aVal2: Integer): Integer; begin Result := 0; if AVal1 > aVal2 then Result := 1 else if AVal1 < aVal2 then Result := -1; end; function GetDeltaOneByPrecision(APrecision: Integer): Double; begin Result := 1 / Power(10, APrecision); // 1 / (10)^APrecision end; function IntToBool(AInt: Integer): Boolean; begin Result := false; case AInt of biTrue: Result := True; biFalse: Result := False; end; end; function BoolToInt(ABool: Boolean): Integer; begin Result := biFalse; case ABool of True: Result := biTrue; False: Result := biFalse; end; end; function BoolToStrL(ABool: Boolean): String; begin Result := ''; if ABool then Result := cBaseCommon11 else Result := cBaseCommon12; end; function GetItemTypeName(AItemType: TItemType): String; begin Result := ''; case AItemType of itProject: Result := cBaseCommon1; itDir: Result := cBaseCommon2; itList: Result := cBaseCommon3; itRoom: Result := cBaseCommon4; itSCSLine: Result := cBaseCommon5; itSCSConnector: Result := cBaseCommon6; itComponLine: Result := cBaseCommon7; itComponCon: Result := cBaseCommon8; end; end; function ItemTypeToIsOwnerFieldName(AItemType: TItemType): String; begin Result := ''; case AItemType of itProject: Result := fnIsProject; itDir: Result := fnIsFolder; itList: Result := fnIsList; itRoom: Result := fnIsRoom; itSCSLine: Result := fnIsSCSline; itSCSConnector: Result := fnIsSCSConnector; itComponLine: Result := fnIsComponLine; itComponCon: Result := fnIsComponConn; end; end; function Int2Str(Data: integer; Radix: integer = 2): string; var Buffer: array[0..32] of char; begin Result := _ltoa(Data, Buffer, Radix); end; function IntToStrF(AInt: Integer; AMinLen: Integer): String; begin Result := ''; Result := IntToStr(AInt); while Length(Result) < AMinLen do Result := '0'+Result; end; function FloatToStrFix(AValue: Double; APrec: Integer): String; var DigCount: Integer; StrLength: Integer; NewLength: Integer; i: Integer; begin //*** Определить количество цифр DigCount := Length(IntToStr(Trunc(AValue)))+APrec; Result := FloatToStrF(AValue, ffFixed, APrec, DigCount); //*** Обрезать нули StrLength := Length(Result); NewLength := StrLength; i := StrLength; while i > 0 do begin if Result[i] = '0' then Dec(NewLength) else if (Result[i] = '.') or (Result[i] = ',') then begin Dec(NewLength); Break; //// BREAK //// end else Break; //// BREAK //// Dec(i); end; if (NewLength < StrLength) and (NewLength > 0) then SetLength(Result, NewLength); end; //function FloatToStrPrec(AValue: Double; APrec: Integer): String; //begin //end; function IsTreeViewItemTypesOfCommonKind(AItemType1, AItemType2: Integer): Boolean; begin Result := false; case AItemType1 of itSCSConnector, itSCSLine: if (AItemType2 = itSCSConnector) or (AItemType2 = itSCSLine) then Result := true; itComponLine, itComponCon, itLinkCompLine, itLinkCompCon: if (AItemType2 = itComponLine) or (AItemType2 = itComponCon) or (AItemType2 = itLinkCompLine) or (AItemType2 = itLinkCompCon) then Result := true; else if AItemType1 = AItemType2 then Result := True; end; end; // ##### Дублирует строку ADupKol раз ##### function DupStr(AStr: String; ADupKol: Integer): String; var i: Integer; ResStr: String; begin Result := ''; ResStr := ''; for i := 0 to ADupKol - 1 do ResStr := ResStr + AStr; Result := Resstr; end; function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer; var I,X: Integer; Len, LenSubStr: Integer; begin if Offset = 1 then Result := Pos(SubStr, S) else begin I := Offset; LenSubStr := Length(SubStr); Len := Length(S) - LenSubStr + 1; while I <= Len do begin if S[I] = SubStr[1] then begin X := 1; while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do Inc(X); if (X = LenSubStr) then begin Result := I; exit; end; end; Inc(I); end; Result := 0; end; end; function SubstrMatches(const SubStr, S: string): Integer; var LastPos: Integer; begin Result := 0; LastPos := 0; while true do begin LastPos := PosEx(SubStr, S, LastPos+1); if LastPos <> 0 then Inc(Result) else Break; //// BREAK //// end; end; function FormatShifrToShortDBN(S: String): String; var i, l: Integer; begin i := PosEx('-', S, 1); while i > 0 do begin l := Length(S); i := i + 1; if i > l then break; //чтобы Абыдно не было repeat if S[i] = '0' then begin Delete(S, i, 1); Dec(l); Dec(i); end else Break; Inc(i); until (S[i] <> '0') or (i = l); i := PosEx('-', S, i); end; Result := S; end; function CheckStrForCommonParam(const AStr1, AStr2: string): Boolean; var i, j: Integer; Str1, Str2: string; begin Result := false; Str1 := ''; Str2 := ''; for i := 1 to Length(AStr1) do begin if AStr1[i] <> ';' then Str1 := Str1 + AStr1[i]; if (i = Length(AStr1)) or (AStr1[i] = ';') then begin if Str1 <> '' then for j := 1 to Length(AStr2) do begin if AStr2[j] <> ';' then Str2 := Str2 + AStr2[j]; if (j = Length(AStr2)) or (AStr2[j] = ';') then begin if Str2 <> '' then if Str1 = Str2 then begin Result := true; Break; //// BREAK //// end; Str2 := ''; end; end; Str1 := ''; end; if Result then Break; //// BREAK //// end; end; function CheckStrHaveRusSymb(const AStr: String): Boolean; var i: Integer; ChCode: Byte; CyrillycSymbls: string; begin Result := false; CyrillycSymbls := 'абвгдеёжзийклмнопрстуфхцчшщьыъэюяАБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЫЪЭЮЯ'; for i := 1 to Length(AStr) do begin if Pos(AStr[i], CyrillycSymbls) <> 0 then begin Result := true; Break; //// BREAK //// end; {ChCode := Ord(AStr[i]); if ((ChCode >= $80) and (ChCode <= $9F)) or // Большие символы ((ChCode >= $A0) and (ChCode <= $AF)) or ((ChCode >= $E0) and (ChCode <= $F7)) then begin Result := true; Break; //// BREAK //// end;} end; end; function CheckStringsHaveRusSymb(AStrings: TStrings): Boolean; var i: integer; begin Result := false; for i := 0 to AStrings.Count - 1 do begin if CheckStrHaveRusSymb(AStrings[i]) then begin Result := true; Break; //// BREAK //// end; end; end; function CheckStringsHaveSameItems(AStrings1, AStrings2: TStrings): Boolean; var i: Integer; begin Result := false; for i := 0 to AStrings1.Count - 1 do begin if AStrings2.IndexOf(AStrings1[i]) <> -1 then begin Result := true; Break; //// BREAK //// end; end; end; function CheckStrInStringsText(const AStrValue, AStringsText: String): Boolean; var Strings: TStringList; begin Result := false; Strings := TStringList.Create; Strings.Text := AStringsText; Result := Strings.IndexOf(AStrValue) <> -1; Strings.Free; end; function GetStrCheckSum(const AStr: String): Integer; var i: integer; begin Result := 0; for i := 1 to Length(AStr) do begin Result := Result + Ord(AStr[i]); end; end; function GetMethodName(const AClass, AMethod: string): string; begin Result := ''; if AClass <> '' then Result := AClass+'.'; Result := Result + AMethod; end; function RemoveSymbolFromStr(AStr: String; ASymb: Char): string; var i: Integer; begin Result := ''; for i := 1 to Length(AStr) do begin if AStr[i] <> ASymb then Result := Result + AStr[i]; end; end; function StringReverse(const AStr: String): String; var i: Integer; begin Result := ''; for i := Length(AStr) downto 1 do Result := Result + AStr[i]; end; function CustMessageDlg(ARus, AUkr: String): TModalResult; var ResID: Integer; begin Result := mrNone; ResID := MessageModal(ARus, cConfirmation, MB_ICONQUESTION or MB_OKCANCEL); case ResID of IDOK: Result := mrOk; IDCANCEL: Result := mrCancel; end; end; procedure ActionCaptionsToHints(AActionList: TActionList); var i: Integer; Obj: TObject; Action: TAction; begin for i := 0 to AActionList.ActionCount - 1 do begin Obj := TObject(AActionList.Actions[i]); if Obj is TAction then begin Action := TAction(Obj); Action.Hint := Action.Caption; end; end; end; procedure AddToExecuteLog_(AString: String; APos: Integer = -1); begin if APos <> -1 then GExecuteLogPosStr := APos; GExecuteLog.Add(DupStr(' ', GExecuteLogPosStr) + AString); {$if Defined(ES_GRAPH_SC)} GExecuteLog.saveToFile(ExeDir + '\Excecute.log'); {$else} GExecuteLog.saveToFile(ExtractFileDir(Application.ExeName) + '\Excecute.log'); {$ifend} end; procedure AddExceptionToLog(const AText: String; AShowText: Boolean = false); var FHandle: TextFile; LogDir: String; FileName: String; CurrDate: TDate; CurrTime: TTime; ShowText: Boolean; begin try LogDir := ExeDir + '\' + dnLog; //if Not DirectoryExists(LogDir) then // CreateDir(LogDir); DefineDir(LogDir); if DirectoryExists(LogDir) then begin CurrDate := Date; CurrTime := Time; FileName := YMDStr+'.'+enLog; FileName := 'Except_' + FileName; FileName := LogDir + '\' + FileName; AssignFile(FHandle, FileName); if FileExists(FileName) then Append(FHandle) else Rewrite(FHandle); try WriteLn(FHandle, DupStr('-', 50)); WriteLn(FHandle, cBaseCommon9+': ' + IntToStrF(HourOf(CurrTime), 2)+':'+ IntToStrF(MinuteOf(CurrTime), 2)+':'+ IntToStrF(SecondOf(CurrTime), 2)); Writeln(FHandle, cBaseCommon10+': "' + AText + '"'); WriteLn(FHandle, ' '); WriteLn(FHandle, ' '); // Tolik -- 16/03/2017 -- if (Pos(LowerCase('Out of mem'), LowerCase(AText)) <> 0) or (Pos(LowerCase('Access deni'), LowerCase(AText)) <> 0) or (Pos(LowerCase('Отказано в дост'), LowerCase(AText)) <> 0) or (Pos(LowerCase('Закройте лишние'), LowerCase(AText)) <> 0) or (Pos(LowerCase('памят'), LowerCase(AText)) <> 0) or (Pos(LowerCase('memory'), LowerCase(AText)) <> 0) or (Pos(LowerCase('insufficient'), LowerCase(AText)) <> 0) or (Pos(LowerCase('нехватки'), LowerCase(AText)) <> 0) then begin Writeln(FHandle, GetMemStatusFull); Writeln(FHandle, getAppMemStatus); end; // finally CloseFile(FHandle); end; {$IF Defined (FINAL_SCS)} ShowText := AShowText; {$ELSE} ShowText := GShowMessTextInAdmBuild; {$IFEND} if ShowText then begin if GIsProgress then PauseProgress(true); MessageError(AText); //09.09.2011 MessageDlg(AText, mtError, [mbOk], 0); if GIsProgress then PauseProgress(False); end; //ShowMessageByType(smtDisplay, AText, Application.Title, MB_ICONERROR or MB_OK); Inc(GExceptionCount); end; except end; end; // Tolik -- 30/12/2015 -- просто вкатать в лог (заебали сообщения на отладке) procedure AddExceptionToLogSilent(const AText: String); var FHandle: TextFile; LogDir: String; FileName: String; CurrDate: TDate; CurrTime: TTime; ShowText: Boolean; begin try LogDir := ExeDir + '\' + dnLog; //if Not DirectoryExists(LogDir) then // CreateDir(LogDir); DefineDir(LogDir); if DirectoryExists(LogDir) then begin CurrDate := Date; CurrTime := Time; FileName := YMDStr+'.'+enLog; FileName := 'Except_' + FileName; FileName := LogDir + '\' + FileName; AssignFile(FHandle, FileName); if FileExists(FileName) then Append(FHandle) else Rewrite(FHandle); try WriteLn(FHandle, DupStr('-', 50)); WriteLn(FHandle, cBaseCommon9+': ' + IntToStrF(HourOf(CurrTime), 2)+':'+ IntToStrF(MinuteOf(CurrTime), 2)+':'+ IntToStrF(SecondOf(CurrTime), 2)); Writeln(FHandle, cBaseCommon10+': "' + AText + '"'); WriteLn(FHandle, ' '); WriteLn(FHandle, ' '); finally CloseFile(FHandle); end; end; except end; end; // procedure AddExceptionToLogEx(const AProcedureName, AException: String; AShowText: Boolean = false); var ProcName: String; begin ProcName := AProcedureName; if ProcName <> '' then ProcName := ProcName + ': '; AddExceptionToLog(ProcName + AException, AShowText); end; procedure AddExceptionToLogExt(const AClass, AMethod, AException: String; AShowText: Boolean = false); begin AddExceptionToLogEx(GetMethodName(AClass, AMethod), AException, AShowText); end; function ComparePropValues(const AVal, ACmpVal: String; ADataType: Integer; ACompareType: Integer): Boolean; var CompareType: TCompareType; IntVal1, IntVal2: Integer; FloatVal1, FloatVal2: Double; PosIdx: Integer; begin Result := false; CompareType := TCompareType(ACompareType); case ADataType of dtFloat: begin FloatVal1 := StrToFloatU(AVal); FloatVal2 := StrToFloatU(ACmpVal); if CompareType = ctEqual then begin if CmpFloatByCP(FloatVal1, FloatVal2) then Result := true; end else if CompareType = ctNoEqual then begin if FloatVal1 <> FloatVal2 then Result := true; end else if CompareType = ctLess then begin if FloatVal1 < FloatVal2 then Result := true; end else if CompareType = ctLessEqual then begin if FloatVal1 <= FloatVal2 then Result := true; end else if CompareType = ctMore then begin if FloatVal1 > FloatVal2 then Result := true; end else if CompareType = ctMoreEqual then begin if FloatVal1 >= FloatVal2 then Result := true; end; end; dtString, dtDimensions, dtStringList: begin PosIdx := Pos(AnsiLowerCase(ACmpVal), AnsiLowerCase(AVal)); if CompareType = ctStrBegin then begin if PosIdx = 1 then Result := true; end else if CompareType = ctStrContent then begin if PosIdx >= 1 then Result := true; end else if CompareType = ctStrIdentical then begin if AnsiLowerCase(ACmpVal) = AnsiLowerCase(AVal) then Result := true; end else if CompareType = ctStrNotContent then begin if PosIdx = 0 then Result := true; end; end; else begin IntVal1 := StrToIntDef(AVal, 0); IntVal2 := StrToIntDef(ACmpVal, 0); if CompareType = ctEqual then begin if IntVal1 = IntVal2 then Result := true; end else if CompareType = ctNoEqual then begin if IntVal1 <> IntVal2 then Result := true; end else if CompareType = ctLess then begin if IntVal1 < IntVal2 then Result := true; end else if CompareType = ctLessEqual then begin if IntVal1 <= IntVal2 then Result := true; end else if CompareType = ctMore then begin if IntVal1 > IntVal2 then Result := true; end else if CompareType = ctMoreEqual then begin if IntVal1 >= IntVal2 then Result := true; end; end; end; end; function ExistsModalForm: Boolean; var i: Integer; procedure Step(AComponent: TComponent); var i: Integer; begin try if AComponent is TForm then if fsModal in TForm(AComponent).FormState then begin Result := true; Exit; ///// EXIT ///// end; for i := 0 to AComponent.ComponentCount - 1 do Step(AComponent.Components[i]); Except on E: Exception do ShowMessage('ExistsModalForm.Error: ' + AComponent.Name + ' Owner: '+ AComponent.Owner.Name); end; end; begin Result := false; try for i := 0 to Application.ComponentCount - 1 do Step(Application.Components[i]); Except on E: Exception do ShowMessage('ExistsModalForm.Error: ' + Application.Components[i].Name + ' Owner: '+ Application.Components[i].Owner.Name); end; {for i := 0 to Screen.FormCount - 1 do if fsModal in Screen.Forms[i].FormState then begin Result := true; Break; ///// BREAK ///// end;} end; function GetAveCharSize(Canvas: TCanvas): TPoint; var I: Integer; Buffer: array[0..51] of Char; begin for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A')); for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a')); GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result)); Result.X := Result.X div 52; end; function MessageDlgLn(const AMsg, ACaption: string; ADlgType: TMsgDlgType; AButtons: TMsgDlgButtons): Word; var FormDlg: TForm; CurrComponent: TComponent; CurrComponName: String; ComponentForMove: TComponent; i, j: Integer; ButtonOrder: TIntList; CurrButtonIndex: Integer; ButtonFromOrder: TButton; ButtonInOrderIndex: TButton; TempInt: Integer; WithToIncrease: Integer; SavedFProgressVisible: Boolean; begin Result := 0; // Ширина для увеличения ширины кнопок WithToIncrease := 10; SavedFProgressVisible := false; if F_Progress <> nil then SavedFProgressVisible := F_Progress.Visible; FormDlg := CreateMessageDialog(AMsg, ADlgType, AButtons); try if F_Progress <> nil then F_Progress.Visible := false; try FormDlg.Caption := ACaption; FormDlg.Position := poMainFormCenter; for i := 0 to FormDlg.ComponentCount - 1 do begin CurrComponent := FormDlg.Components[i]; CurrComponName := AnsiUpperCase(CurrComponent.Name); if CurrComponent is TButton then begin if CurrComponName = 'YES' then TButton(CurrComponent).Caption := cBaseCommon11 else if CurrComponName = 'NO' then TButton(CurrComponent).Caption := cBaseCommon12 else if CurrComponName = 'OK' then TButton(CurrComponent).Caption := cBaseCommon13 else if CurrComponName = 'CANCEL' then TButton(CurrComponent).Caption := cBaseCommon14 else if CurrComponName = 'ABORT' then TButton(CurrComponent).Caption := cBaseCommon15 else if CurrComponName = 'RETRY' then TButton(CurrComponent).Caption := cBaseCommon16 else if CurrComponName = 'IGNORE' then TButton(CurrComponent).Caption := cBaseCommon17 else if CurrComponName = 'ALL' then TButton(CurrComponent).Caption := cBaseCommon18 else if CurrComponName = 'NOTOALL' then TButton(CurrComponent).Caption := cBaseCommon19 else if CurrComponName = 'YESTOALL' then TButton(CurrComponent).Caption := cBaseCommon20 else if CurrComponName = 'HELP' then TButton(CurrComponent).Caption := cBaseCommon21; end; end; // Кнопки да для всех и нет для всех должны находится в начале if (mbYesToAll in AButtons) or (mbNoToAll in AButtons) then begin ButtonOrder := TIntList.Create; // Составляем нужный порядок кнопок ButtonOrder.Add(Ord(mrYes)); ButtonOrder.Add(Ord(mrYesToAll)); ButtonOrder.Add(Ord(mrNo)); ButtonOrder.Add(Ord(mrNoToAll)); ButtonOrder.Add(Ord(mrOK)); ButtonOrder.Add(Ord(mrCancel)); ButtonOrder.Add(Ord(mrAbort)); ButtonOrder.Add(Ord(mrRetry)); ButtonOrder.Add(Ord(mrIgnore)); ButtonOrder.Add(Ord(mrAll)); //ButtonOrder.Add(Ord(mrHelp)); for i := 0 to ButtonOrder.Count - 1 do begin CurrButtonIndex := -1; ButtonFromOrder := nil; ButtonInOrderIndex := nil; for j := 0 to FormDlg.ComponentCount - 1 do begin CurrComponent := FormDlg.Components[j]; if CurrComponent is TButton then begin Inc(CurrButtonIndex); if TButton(CurrComponent).ModalResult = ButtonOrder[i] then ButtonFromOrder := TButton(CurrComponent); if CurrButtonIndex = i then ButtonInOrderIndex := TButton(CurrComponent); // Поменять местами кнопки if (ButtonFromOrder <> nil) and (ButtonInOrderIndex <> nil) then if ButtonFromOrder <> ButtonInOrderIndex then begin TempInt := ButtonFromOrder.Left; ButtonFromOrder.Left := ButtonInOrderIndex.Left; ButtonInOrderIndex.Left := TempInt; TempInt := ButtonFromOrder.TabOrder; ButtonFromOrder.TabOrder := ButtonInOrderIndex.TabOrder; ButtonInOrderIndex.TabOrder := TempInt; Break; //// BREAK //// end; end; end; end; FreeAndNil(ButtonOrder); end; for i := 0 to FormDlg.ComponentCount - 1 do begin CurrComponent := FormDlg.Components[i]; if CurrComponent is TButton then begin if (TButton(CurrComponent).ModalResult = mrYesToAll) or (TButton(CurrComponent).ModalResult = mrNoToAll) then begin TButton(CurrComponent).Width := TButton(CurrComponent).Width + WithToIncrease; TButton(CurrComponent).Left := TButton(CurrComponent).Left - Round(WithToIncrease/2); // Все кнопки что левее, сместить влево. Те что правее - вправо for j := 0 to FormDlg.ComponentCount - 1 do begin ComponentForMove := FormDlg.Components[j]; if ComponentForMove <> CurrComponent then if ComponentForMove is TButton then begin if TButton(ComponentForMove).Left < TButton(CurrComponent).Left then TButton(ComponentForMove).Left := TButton(ComponentForMove).Left - Round(WithToIncrease/2) else if TButton(ComponentForMove).Left > TButton(CurrComponent).Left then TButton(ComponentForMove).Left := TButton(ComponentForMove).Left + Round(WithToIncrease/2); end; end; end; end; end; except end; Result := FormDlg.ShowModal; finally //FreeAndNil(FormComponents); FreeAndNil(FormDlg); if F_Progress <> nil then F_Progress.Visible := SavedFProgressVisible; end; end; function MessageModal(const AText, ACaption: String; AStyle: Uint): Integer; var //FormDlg: TForm; DlgType: TMsgDlgType; DlgButtons: TMsgDlgButtons; //i: Integer; //FormComponents: TObjectList; //CurrComponent: TComponent; //CurrComponName: String; ModalResult: TModalResult; //BitBtn: TRzBitBtn; begin Result := 0; DlgType := mtInformation; if (AStyle and MB_ICONEXCLAMATION) = MB_ICONEXCLAMATION then begin DlgType := mtWarning; end; if (AStyle and MB_ICONWARNING) = MB_ICONWARNING then begin DlgType := mtWarning; end; if (MB_ICONINFORMATION and AStyle) = MB_ICONINFORMATION then DlgType := mtInformation; if (MB_ICONASTERISK and AStyle) = MB_ICONASTERISK then DlgType := mtInformation; if (MB_ICONQUESTION and AStyle) = MB_ICONQUESTION then DlgType := mtConfirmation; if (MB_ICONSTOP and AStyle) = MB_ICONSTOP then DlgType := mtError; if (MB_ICONERROR and AStyle) = MB_ICONERROR then DlgType := mtError; if (MB_ICONHAND and AStyle) = MB_ICONHAND then DlgType := mtError; //*** Buttons DlgButtons := []; if (MB_OK and AStyle) = MB_OK then DlgButtons := [mbOK]; if (MB_ABORTRETRYIGNORE and AStyle) = MB_ABORTRETRYIGNORE then DlgButtons := [mbAbort, mbRetry, mbIgnore]; if (MB_OKCANCEL and AStyle) = MB_OKCANCEL then DlgButtons := [mbOK, mbCancel]; if (MB_RETRYCANCEL and AStyle) = MB_RETRYCANCEL then DlgButtons := [mbRetry, mbCancel]; if (MB_YESNO and AStyle) = MB_YESNO then DlgButtons := [mbYes, mbNo]; if (MB_YESNOCANCEL and AStyle) = MB_YESNOCANCEL then DlgButtons := [mbYes, mbNo, mbCancel]; ModalResult := MessageDlgLn(AText, ACaption, DlgType, DlgButtons); case ModalResult of mrNone: Result := 0; //IDNONE; mrOk: Result := IDOK; mrCancel: Result := IDCANCEL; mrAbort: Result := IDABORT; mrRetry: Result := IDRETRY; mrIgnore: Result := IDIGNORE; mrYes: Result := IDYES; mrNo: Result := IDNO; mrAll: Result := 0; //IDALL; mrNoToAll: Result := 0; //IDNOTOALL; mrYesToAll: Result := 0; //IDYESTOALL; end; { FormDlg := nil; FormDlg := CreateMessageDialog(AText, DlgType, DlgButtons); //FormComponents := TObjectList.Create(false); try try FormDlg.Caption := ACaption; for i := 0 to FormDlg.ComponentCount - 1 do begin CurrComponent := FormDlg.Components[i]; CurrComponName := AnsiUpperCase(CurrComponent.Name); if CurrComponent is TButton then begin if CurrComponName = 'YES' then TButton(CurrComponent).Caption := cBaseCommon11 else if CurrComponName = 'NO' then TButton(CurrComponent).Caption := cBaseCommon12 else if CurrComponName = 'OK' then TButton(CurrComponent).Caption := cBaseCommon13 else if CurrComponName = 'CANCEL' then TButton(CurrComponent).Caption := cBaseCommon14 else if CurrComponName = 'ABORT' then TButton(CurrComponent).Caption := cBaseCommon15 else if CurrComponName = 'RETRY' then TButton(CurrComponent).Caption := cBaseCommon16 else if CurrComponName = 'IGNORE' then TButton(CurrComponent).Caption := cBaseCommon17 else if CurrComponName = 'ALL' then TButton(CurrComponent).Caption := cBaseCommon18 else if CurrComponName = 'NOTOALL' then TButton(CurrComponent).Caption := cBaseCommon19 else if CurrComponName = 'YESTOALL' then TButton(CurrComponent).Caption := cBaseCommon20 else if CurrComponName = 'HELP' then TButton(CurrComponent).Caption := cBaseCommon21; end; end; ModalResult := FormDlg.ShowModal; case ModalResult of mrNone: Result := 0; //IDNONE; mrOk: Result := IDOK; mrCancel: Result := IDCANCEL; mrAbort: Result := IDABORT; mrRetry: Result := IDRETRY; mrIgnore: Result := IDIGNORE; mrYes: Result := IDYES; mrNo: Result := IDNO; mrAll: Result := 0; //IDALL; mrNoToAll: Result := 0; //IDNOTOALL; mrYesToAll: Result := 0; //IDYESTOALL; end; except end; finally //FreeAndNil(FormComponents); FreeAndNil(FormDlg); end;} end; procedure MessageError(const AText: string); begin MessageModal(AText, ApplicationName, MB_OK or MB_ICONERROR); end; procedure MessageInfo(const AText: string); begin MessageModal(AText, ApplicationName, MB_OK or MB_ICONINFORMATION); end; function MessageQuastYN(const AText: string): Integer; begin Result := MessageModal(AText, ApplicationName, MB_YESNO or MB_ICONQUESTION); end; function MessageQuastYNC(const AText: string): Integer; begin Result := MessageModal(AText, ApplicationName, MB_YESNOCANCEL or MB_ICONQUESTION); end; function InputForm(AForm: TForm; ACaption, APrompt, ADefault: Variant; ADataType: Integer = dtString): Variant; begin Result := null; if AForm = nil then AForm := F_ProjMan; case ADataType of dtString: Result := ''; dtFloat, dtInteger: Result := 0; end; TF_Main(AForm).F_InputBox.GInputFormMode := imInputText; TF_Main(AForm).F_InputBox.Caption := ACaption; //TF_Main(AForm).F_InputBox.Label_Prompt.Caption := APrompt; TF_Main(AForm).F_InputBox.pnComboInputPrompt.Caption := APrompt; case ADataType of dtString: begin TF_Main(AForm).F_InputBox.GInputFormMode := imInputText; TF_Main(AForm).F_InputBox.edText.Text := ADefault; end; dtFloat, dtInteger: begin TF_Main(AForm).F_InputBox.GInputFormMode := imInputFloat; if ADataType = dtFloat then TF_Main(AForm).F_InputBox.seValue.Properties.ValueType := vtFloat; if ADataType = dtInteger then TF_Main(AForm).F_InputBox.seValue.Properties.ValueType := vtInt; TF_Main(AForm).F_InputBox.seValue.Value := ADefault; end; end; if TF_Main(AForm).F_InputBox.ShowModal = mrOK then case ADataType of dtString: Result := TF_Main(AForm).F_InputBox.edText.Text; dtFloat, dtInteger: Result := TF_Main(AForm).F_InputBox.seValue.Value; end; end; function InputPassQuery(const ACaption, APrompt: string; var Value: string): Boolean; var Form: TForm; Prompt: TLabel; Edit: TEdit; DialogUnits: TPoint; ButtonTop, ButtonWidth, ButtonHeight: Integer; begin Result := False; Form := TForm.Create(Application); with Form do try Canvas.Font := Font; DialogUnits := GetAveCharSize(Canvas); BorderStyle := bsDialog; Caption := ACaption; ClientWidth := MulDiv(180, DialogUnits.X, 4); Position := poScreenCenter; Prompt := TLabel.Create(Form); with Prompt do begin Parent := Form; Caption := APrompt; Left := MulDiv(8, DialogUnits.X, 4); Top := MulDiv(8, DialogUnits.Y, 8); Constraints.MaxWidth := MulDiv(164, DialogUnits.X, 4); WordWrap := True; end; Edit := TEdit.Create(Form); with Edit do begin Parent := Form; Left := Prompt.Left; Top := Prompt.Top + Prompt.Height + 5; Width := MulDiv(164, DialogUnits.X, 4); MaxLength := 255; Text := Value; PasswordChar := '*'; SelectAll; end; ButtonTop := Edit.Top + Edit.Height + 15; ButtonWidth := MulDiv(50, DialogUnits.X, 4); ButtonHeight := MulDiv(14, DialogUnits.Y, 8); with TButton.Create(Form) do begin Parent := Form; Caption := SMsgDlgOK; ModalResult := mrOk; Default := True; SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight); end; with TButton.Create(Form) do begin Parent := Form; Caption := cBaseCommon14; //SMsgDlgCancel; ModalResult := mrCancel; Cancel := True; SetBounds(MulDiv(92, DialogUnits.X, 4), Edit.Top + Edit.Height + 15, ButtonWidth, ButtonHeight); Form.ClientHeight := Top + Height + 13; end; if ShowModal = mrOk then begin Value := Edit.Text; Result := True; end; finally Form.Free; end; end; function FillPropCompareTypesByDataType(AStrings: TStrings; ADataType: Integer): Integer; begin Result := -1; FreeStringsObjects(AStrings, true); case ADataType of dtFloat, dtInteger: begin AddIDToStrings(Ord(ctEqual), cFilterConfigurator4_1, AStrings); AddIDToStrings(Ord(ctNoEqual), cFilterConfigurator4_2, AStrings); AddIDToStrings(Ord(ctLess), cFilterConfigurator4_3, AStrings); AddIDToStrings(Ord(ctLessEqual), cFilterConfigurator4_4, AStrings); AddIDToStrings(Ord(ctMore), cFilterConfigurator4_5, AStrings); AddIDToStrings(Ord(ctMoreEqual), cFilterConfigurator4_6, AStrings); Result := IndexOfIDInStrings(Ord(ctEqual), AStrings); end; dtString, dtDimensions, dtStringList: begin AddIDToStrings(Ord(ctStrBegin), cFilterConfigurator4_7, AStrings); AddIDToStrings(Ord(ctStrContent), cFilterConfigurator4_8, AStrings); AddIDToStrings(Ord(ctStrIdentical), cFilterConfigurator4_9, AStrings); AddIDToStrings(Ord(ctStrNotContent), cFilterConfigurator4_10, AStrings); Result := IndexOfIDInStrings(Ord(ctStrBegin), AStrings); end; else begin AddIDToStrings(Ord(ctEqual), cFilterConfigurator4_1, AStrings); AddIDToStrings(Ord(ctNoEqual), cFilterConfigurator4_2, AStrings); Result := 0; end; end; end; procedure FillPropValuesByDataType(AStrings: TStrings; ADataType: Integer); begin FreeStringsObjects(AStrings, true); case ADataType of dtCompStateType: begin AddIDToStrings(-1, '', AStrings); AddIDToStrings(oitProjectible, cMakeEditPropRel_Msg3_9, AStrings); AddIDToStrings(oitActive, cMakeEditPropRel_Msg3_10, AStrings); end; dtCableCanalElementType: begin AddIDToStrings(contNone, '', AStrings); AddIDToStrings(contCork, ctnCork, AStrings); AddIDToStrings(contAnglePlane, ctnAnglePlane, AStrings); AddIDToStrings(contTjoin, ctnTjoin, AStrings); AddIDToStrings(contCross, ctnCross, AStrings); AddIDToStrings(contAngleIn, ctnAngleIn, AStrings); AddIDToStrings(contAngleOut, ctnAngleOut, AStrings); AddIDToStrings(contADapter, ctnADapter, AStrings); AddIDToStrings(contConnector, ctnConnector, AStrings); AddIDToStrings(contWallCork, ctnWallCork, AStrings); end; dtConnectionKind: begin AddIDToStrings(-1, '', AStrings); AddIDToStrings(tckHubOfPipe, tcknHubOfPipe, AStrings); AddIDToStrings(tckCapillarySoldering, tcknCapillarySoldering, AStrings); AddIDToStrings(tckMechanicalCompressive, tcknMechanicalCompressive, AStrings); AddIDToStrings(tckMechanicalPress, tcknMechanicalPress, AStrings); AddIDToStrings(tckMechanicalTread, tcknMechanicalTread, AStrings); AddIDToStrings(tckPress, tcknPress, AStrings); AddIDToStrings(tckWeldingConnection, tcknWeldingConnection, AStrings); AddIDToStrings(tckWeldingButt, tcknWeldingButt, AStrings); AddIDToStrings(tckWeldHubOfPipe, tcknWeldHubOfPipe, AStrings); AddIDToStrings(tckWeldElectric, tcknWeldElectric, AStrings); end; dtPlaneMaterialType: begin AddIDToStrings(pmtNone, '', AStrings); //AddIDToStrings(pmtSheeting, pmtnSheeting, AStrings); //AddIDToStrings(pmtRoll, pmtnRoll, AStrings); //AddIDToStrings(pmtTile, pmtnTile, AStrings); AddIDToStrings(pmtSheetSlate, pmtnSheetSlate, AStrings); AddIDToStrings(pmtSheetSteel, pmtnSheetSteel, AStrings); AddIDToStrings(pmtRoller, pmtnRoller, AStrings); AddIDToStrings(pmtTileMetal, pmtnTileMetal, AStrings); AddIDToStrings(pmtTileCeramic, pmtnTileCeramic, AStrings); AddIDToStrings(pmtTileBitumen, pmtnTileBitumen, AStrings); AddIDToStrings(pmtTileInterlocking, pmtnTileInterlocking, AStrings); AddIDToStrings(pmtOndura, pmtnOndura, AStrings); AddIDToStrings(pmtOnduline, pmtnOnduline, AStrings); AddIDToStrings(pmtFronton, pmtnFronton, AStrings); AddIDToStrings(pmtRoofBase, pmtnRoofBase, AStrings); end; dtRoofHipType: begin AddIDToStrings(rhtNone, '', AStrings); AddIDToStrings(rhtApex, rhtnApex, AStrings); AddIDToStrings(rhtValley, rhtnValley, AStrings); AddIDToStrings(rhtEaves, rhtnEaves, AStrings); AddIDToStrings(rhtEnd, rhtnEnd, AStrings); AddIDToStrings(rhtJunction, rhtnJunction, AStrings); AddIDToStrings(rhtRoofHip, rhtnRoofHip, AStrings); end; dtRoofHipApexType: begin AddIDToStrings(rhatNone, '', AStrings); AddIDToStrings(rhatLargeRound, rhatnLargeRound, AStrings); AddIDToStrings(rhatSmallRound, rhatnSmallRound, AStrings); AddIDToStrings(rhatTrapezoidal, rhatnTrapezoidal, AStrings); AddIDToStrings(rhatTriangularStraight, rhatnTriangularStraight, AStrings); AddIDToStrings(rhatStraight, rhatnStraight, AStrings); end; dtRoofHipValleyType: begin AddIDToStrings(rhvtNone, '', AStrings); AddIDToStrings(rhvtDeep, rhvtnDeep, AStrings); AddIDToStrings(rhvtDecorative, rhvtnDecorative, AStrings); AddIDToStrings(rhvtLarge, rhvtnLarge, AStrings); end; end; end; function GetMasterTracingCaption(const AComponentTypeSysName: String): String; begin Result := ''; if CheckSysNameIsCableChannel(AComponentTypeSysName) then Result := cMasterCableCanalTracing_Msg13_1 else Result := cMasterCableCanalTracing_Msg13_2; end; function GetCaptionNormsResourcesTotalKolvo(AUOM: Integer; ALength: Double): String; begin Result := cNameTotalkolvo +' ('+cNameFor+' '+FloatToStr(RoundCP(FloatInUOM(ALength, umMetr, AUOM)))+' '+GetNameUOM(AUOM, true)+')'; end; function GetDisplayTextInFLoatUOMMin2(ATextValue: String; AUOM: Integer): String; var ValueFloat: Double; begin Result := ATextValue; try if ATextValue <> '' then begin ValueFloat := StrToFloat_My(ATextValue); ValueFloat := FloatInUOM(ValueFloat, umSM, ConvertUOMToMin(AUOM), 2); Result := FloatToStr(RoundCP(ValueFloat)); end; except end; end; function GetDisplayTextInFLoatUOM(ATextValue: String; AUOM: Integer): String; var ValueFloat: Double; begin Result := ATextValue; try if ATextValue <> '' then begin ValueFloat := StrToFloat_My(ATextValue); ValueFloat := FloatInUOM(ValueFloat, umMetr, AUOM); Result := FloatToStr(RoundCP(ValueFloat)); end; except end; end; function GetDisplayTextToNORMExpenseForLength(const ATextValue: String; AUOM: Integer): String; var ValueFloat: Double; begin Result := ATextValue; try // Преобразуем расход из метра на AUOM if ATextValue <> '' then begin ValueFloat := StrToFloat_My(ATextValue); ValueFloat := FloatInUOM(ValueFloat, AUOM, umMetr); Result := FloatToStr(RoundCP(ValueFloat)); end; except end; end; function GetDisplayTextToNORMLaborTime(const ATextValue: String; aShowDays: Boolean = false): String; var //TimeUOM: Integer; TimeMin: Integer; Dy, Hr, Min: Integer; begin Result := ''; if ATextValue <> '' then begin try TimeMin := StrToIntDef(ATextValue, 0); Hr := TimeMin div 60; Min := TimeMin mod 60; //if (Hr <> 0) and (Min <> 0) then // Result := IntToStr(Hr)+'/'+IntToStr(Min); if aShowDays then begin Dy := Hr div cntWorkDayHours; if Dy > 0 then begin Hr := Hr mod cntWorkDayHours; Result := IntToStr(Dy)+' '+cBaseCommon85_3; end; end; if Hr <> 0 then begin if Result <> '' then Result := Result + ' '; Result := Result + IntToStr(Hr)+' '+cBaseCommon85_1; end; if Min <> 0 then begin if Result <> '' then Result := Result + ' '; Result := Result + IntToStr(Min)+' '+cBaseCommon85_2; end; except on E: Exception do AddExceptionToLogEx('GetDisplayTextToNORMLaborTime', E.Message); end; //TimeUOM := ARecord.Values[GT_NB_NormsTimeUOM.Index]; //if TimeUOM <> 0 then // AText := AText +' '+ GetTimeUOMName(TimeUOM); end else Result := ATextValue; end; function GetFileNameToSaveProtocol: String; var LogDir: String; Dat: TDate; Tim: TTime; begin {$if Defined(ES_GRAPH_SC)} LogDir := ExeDir + '\'+dnLog; {$else} LogDir := ExtractFileDir(Application.ExeName) + '\'+dnLog; {$ifend} //if Not DirectoryExists(LogDir) then // CreateDir(LogDir); DefineDir(LogDir); Dat := Date; Tim := Time; Result := LogDir+'\'+'ExtProtocol_'+ IntToStrF(YearOf(Dat), 4)+ IntToStrF(MonthOf(Dat), 2)+ IntToStrF(DayOf(Dat), 2)+'__'+ IntToStrF(HourOf(Tim), 2)+'_'+ IntToStrF(MinuteOf(Tim), 2)+'_'+ IntToStrF(SecondOf(Tim), 2)+ '.'+enLog; end; function GetNoExistsFileNameForCopy(const AFileName: String): String; var DirName: String; FileName: String; ExtName: String; NameIndex: Integer; CurrFileName: String; begin Result := ''; if Not FileExists(AFileName) then Result := AFileName else begin DirName := ExtractFileDir(AFileName); FileName := ExtractFileNameOnly(AFileName); ExtName := ExtractFileExt(AFileName); NameIndex := 0; while True do begin Inc(NameIndex); CurrFileName := DirName + '\' +FileName + IntToStr(NameIndex) + ExtName; if Not FileExists(CurrFileName) then begin Result := CurrFileName; Break; //// BREAK //// end; end; end; end; function GetPropStrValueByDisplay(const ADisplayText, ASysName: String; ADataType, AUOM: Integer): String; var CurrFloat: Double; tmpint: integer; tmptext: string; begin Result := ''; case ADataType of dtInteger: begin try CurrFloat := StrToIntDef(ADisplayText, 0); PropValueInUOM(CurrFloat, ASysName, AUOM, umMetr); Result := FloatToStr(Int(CurrFloat)); except end; end; dtFloat: try CurrFloat := StrToFloatDef_My(ADisplayText, 0); PropValueInUOM(CurrFloat, ASysName, AUOM, umMetr); CurrFloat := RoundCP(CurrFloat); Result := FloatToStrU(CurrFloat); except end; dtDate: try Result := DateToStrU(StrToDateDef(ADisplayText, 0)); except end; dtCableCanalElementType: try Result := IntToStr(GetCableChannelElementByName(ADisplayText)); if Result = IntToStr(contNone) then Result := IntToStr(StrToIntDef(ADisplayText, contNone)); except end; dtConnectionKind: try Result := IntToStr(GetTubeConnectKindByName(ADisplayText)); except end; else begin Result := ADisplayText; if ASysName = 'COLOR' then begin try if Result <> '' then begin TmpText := inttohex(strtoint(Result), 6); TmpText := copy(TmpText, 5, 2) + copy(TmpText, 3, 2) + copy(TmpText, 1, 2); Result := inttostr(StrToInt('$0' + TmpText)); end; except end; end; end; end; end; function HitTestCloseControl(AControl: TControl; AMousePoint: TPoint): Boolean; begin Result := false; if AMousePoint.X > {RzPanel1.Left +} AControl.Width - 17 then Result := true; end; procedure OnNormsResourcesCustomDrawCell(ACanvas: TcxCanvas; AViewInfo: TcxGridTableDataCellViewInfo; AIsResourceIndex, AGUIDNBComponIndex, ATotalKolvoIndex: Integer; AHaveNorms: Boolean); var ptrColorsInfo: PColorsInfo; SavedBrushColor: Integer; i: Integer; Rect: TRect; begin ptrColorsInfo := nil; // Если выделенная ячейка, то оставляем все как было if AViewInfo.RecordViewInfo.Focused {and AViewInfo.Item.Focused} then begin EmptyProcedure; //Exit; ///// EXIT ///// //AViewInfo.Style.BorderColor := clGreen; //AViewInfo.Style.BorderStyle := ebs3D; //AViewInfo.Style.BorderColor := clRed; //AViewInfo.Style.Color := clGreen; //AViewInfo.EditViewInfo.Paint(ACanvas); //AViewInfo.EditViewInfo.BorderWidth := 5; end; if (ATotalKolvoIndex <> -1) and (AViewInfo.Item.Index = ATotalKolvoIndex) then begin //ACanvas.Brush.Color := clRed; //ACanvas.Font.Color := clBlack; ptrColorsInfo := @GSCSIni.Colors.TotalKolvo; end else begin // если ресурс if AViewInfo.GridRecord.Values[AIsResourceIndex] = true then //if Sender.DataController.Values[AViewInfo.RecordViewInfo.Index, GT_NormsResourcesIsResource.Index] = true then begin // если обычный ресурс if AViewInfo.GridRecord.Values[AGUIDNBComponIndex] = '' then ptrColorsInfo := @GSCSIni.Colors.Resource else ptrColorsInfo := @GSCSIni.Colors.ResourceCompon; end else if AHaveNorms then ptrColorsInfo := @GSCSIni.Colors.Norm; end; if ptrColorsInfo <> nil then if ptrColorsInfo.Active then begin //ACanvas.Brush.Color := ptrColorsInfo.Back; ACanvas.Font.Color := ptrColorsInfo.Font; //ACanvas.FillRect(AViewInfo.Bounds); ACanvas.FrameRect(Rect, clBlack, 5); ACanvas.Brush.Color := ptrColorsInfo.Back; //ACanvas.FillRect(AViewInfo.Bounds); //Rect := AViewInfo.Bounds; //Rect.Top := Rect.Top + 2; //Rect.Bottom := Rect.Bottom - 2; { Rect.TopLeft.X := Rect.TopLeft.X - 1; // Было несовпадение границ на пиксель ACanvas.FillRect(Rect); //ACanvas.Font := csItalic.Font; ACanvas.DrawText(AViewInfo.DisplayValue, AViewInfo.Bounds, cxAlignCenter); ACanvas.Brush.Style := bsSolid; ACanvas.FrameRect(Rect, clBlack);} end; end; procedure SaveProtocolToFile(AFileName: String); begin //SpareStr := GLog.Strings[GLog.Count - 1]; //GLog.Delete(GLog.Count - 1); GLog.SaveToFile(AFileName); GLog.Clear; end; // ##### Выводит собщение на: экран, протокол, или не выводит ##### procedure ShowMessageByType(AHandle: HWND; AShowMessageType: TShowMessageType; AText, ACaption: String; AStyle: uint); var FileName: String; //SpareStr: String; begin try case AShowMessageType of smtDisplay: begin MessageModal(AText, ACaption, AStyle); //MessageBox({AHandle,}0, PChar(AText), PChar(ACaption), AStyle); //MessageDlg(AText, mtInformation, [mbOk], 0); end; smtProtocol: if GCadForm <> nil then if GCadForm.FCADListID > 0 then if GCadForm.mProtocol <> nil then GCadForm.mProtocol.Lines.Add(AText); end; if Assigned(GLog) then begin //try GLog.Add(TimeToStr(Time)+ ' ' +AText); GLog.Add(''); if GLog.Count > 20000 then begin FileName := GetFileNameToSaveProtocol; SaveProtocolToFile(FileName); GLog.Add(cBaseCommon22+' '+FileName); GLog.Add(''); GLog.Add(''); //GLog.Add(SpareStr); GLog.Add(TimeToStr(Time)+ ' ' +AText); GLog.Add(''); end; //except //end; end; except on E: Exception do AddExceptionToLog('ShowMessageByType: '+E.Message); end; end; procedure ShowError(AProcName, AMessage: String); var F: TextFile; begin {ShowMessage('EXCEPTION:'+#13+ 'В функции "'+AProcName+'" возникла ошибка.'+#13+#13+ 'Описание ошибки:'+#13+AMessage +#13+#13+'Просим извенить за неудобства.');} try try MessageModal('EXCEPTION:'+#13+ cBaseCommon43_1+' "'+AProcName+'" '+cBaseCommon43_2+#13+#13+ cBaseCommon43_3+':'+#13+AMessage {+#13+#13+'Просим извинения за неудобства.'}, Application.Title, MB_ICONERROR or MB_OK); AssignFile(F, fnLogError); if FileExists(fnLogError) then Append(F) else Rewrite(F); WriteLn(F, DupStr('-', 50)); WriteLn(F, cBaseCommon44_1+': ' + DateTimeToStr(Now)); Writeln(F, cBaseCommon44_2+': "' + AProcName + '"'); Writeln(F, cBaseCommon43_3+': "' + Amessage + '"'); WriteLn(F, ' '); WriteLn(F, ' '); except ShowMessage('ShowError'); end; finally CloseFile(F); end; end; procedure ShowExcept(AMessage: String); begin ShowMessage(AMessage); end; procedure SetFromActualSize(AForm: TForm); var MaxHeigth: Integer; MaxWidth: Integer; CurrControl: TControl; i: Integer; begin MaxHeigth := 0; MaxWidth := 0; for i := 0 to AForm.ControlCount - 1 do begin CurrControl := AForm.Controls[i]; if CurrControl.Visible then begin //if Not (CurrControl.Align in [alLeft, alRight]) then if (CurrControl.Top + CurrControl.Height) > MaxHeigth then MaxHeigth := CurrControl.Top + CurrControl.Height; //if Not (CurrControl.Align in [alTop, alBottom]) then if (CurrControl.Left + CurrControl.Width) > MaxWidth then MaxWidth := CurrControl.Left + CurrControl.Width; end; end; AForm.Height := (AForm.BorderWidth*2) + MaxHeigth + 29; AForm.Width := (AForm.BorderWidth*2) + MaxWidth + 29; end; procedure SetMiddleControlPos(AControl: TControl); var ParentControl: TControl; begin try //Result := AControlRect; //ResRect.Left := Round(AParentRect.) ParentControl := nil; ParentControl := AControl.Parent; if ParentControl = nil then Exit; ///// EXIT ///// AControl.Left := Round(ParentControl.Width / 2) - Round(AControl.Width / 2); AControl.Top := Round(ParentControl.Height / 2) - Round(AControl.Height / 2); except on E: Exception do AddExceptionToLog('GetMiddleControlRect: '+E.Message); end; end; procedure SetMiddleControlChilds(AControl, AMainControl: TControl); var i: Integer; ChildCount: Integer; ChildControl: TControl; ChildComponent: TComponent; ControlsSorted: TRapObjectList; ControlWidth: Integer; TotalChildWidth: Integer; SpaceCount: Integer; SpaceWidth: Integer; LeftPos: Integer; begin try if AControl = nil then Exit; ///// EXIT ////// {ControlWidth := AControl.Width; TotalChildWidth := 0; ChildCount := 0; for i := 0 to AMainControl.ComponentCount - 1 do if (AMainControl.Components[i] is TControl) and (TControl(AMainControl.Components[i]).Parent = AControl) and (TControl(AMainControl.Components[i]).Visible) then begin TotalChildWidth := TotalChildWidth + TControl(AMainControl.Components[i]).Width; ChildCount := ChildCount + 1; end; SpaceCount := ChildCount + 1; SpaceWidth := Round((AControl.Width - TotalChildWidth) / SpaceCount); LeftPos := SpaceWidth; for i := 0 to AMainControl.ComponentCount - 1 do if (AMainControl.Components[i] is TControl) and (TControl(AMainControl.Components[i]).Parent = AControl) and (TControl(AMainControl.Components[i]).Visible) then begin ChildControl := TControl(AMainControl.Components[i]); ChildControl.Left := LeftPos; LeftPos := LeftPos + ChildControl.Width + SpaceWidth; end; } ControlsSorted := TRapObjectList.Create; ControlWidth := AControl.Width; TotalChildWidth := 0; ChildCount := 0; for i := 0 to AMainControl.ComponentCount - 1 do begin ChildComponent := AMainControl.Components[i]; if (ChildComponent is TControl) and (TControl(ChildComponent).Parent = AControl) and (TControl(ChildComponent).Visible) then begin ChildControl := TControl(ChildComponent); TotalChildWidth := TotalChildWidth + ChildControl.Width; ChildCount := ChildCount + 1; ControlsSorted.Insert(ChildControl, @ChildControl.Left); end; end; SpaceCount := ChildCount + 1; SpaceWidth := Round((AControl.Width - TotalChildWidth) / SpaceCount); LeftPos := SpaceWidth; for i := 0 to ControlsSorted.Count - 1 do begin ChildControl := TControl(ControlsSorted[i]); ChildControl.Left := LeftPos; LeftPos := LeftPos + ChildControl.Width + SpaceWidth; end; FreeAndNil(ControlsSorted); except on E: Exception do AddExceptionToLog('SetMiddleControlChilds: '+E.Message); end; end; procedure SetDisplayTextToGridTablePropIzm(var AText: string; ARecord: TcxCustomGridRecord; ASysNameIndex, AUOM: Integer); begin if ARecord.Values[ASysNameIndex] <> null then AText := GetNameUOMForProperty(AText, ARecord.Values[ASysNameIndex], AUOM); end; procedure SetDisplayTextToGridTablePropValue(var AText: string; ARecord: TcxCustomGridRecord; ADataTypeIndex, ASysNameIndex, AUOM: Integer); var CurrFloat: Double; TempFloat: Double; SysName: String; begin SysName := ''; if ARecord.Values[ADataTypeIndex] <> null then case ARecord.Values[ADataTypeIndex] of dtInteger: begin try CurrFloat := StrToInt(AText); if ARecord.Values[ASysNameIndex] <> null then SysName := ARecord.Values[ASysNameIndex]; PropValueInUOM(CurrFloat, SysName, umMetr, AUOM); AText := FloatToStr(Int(CurrFloat)); except end; end; dtFloat: try if (AText = '') then begin CurrFloat := 0; AText := FloatToStr(CurrFloat); end else begin CurrFloat := StrToFloatU(AText); if ARecord.Values[ASysNameIndex] <> null then SysName := ARecord.Values[ASysNameIndex]; PropValueInUOM(CurrFloat, SysName, umMetr, AUOM); //if SysName = pnExpenseForMetr then // CurrFloat := RoundCP(FloatInUOM(CurrFloat, AUOM, umMetr)) //else //if GPropSysNameInUOM.IndexOf(SysName) <> -1 then // CurrFloat := RoundCP(FloatInUOM(CurrFloat, umMetr, AUOM)); if AUOM = 6 then begin TempFloat := Round2(CurrFloat); if abs(TempFloat - Round0(CurrFloat)) <= 0.0300001 then CurrFloat := Round0(CurrFloat) else CurrFloat := Round2(CurrFloat) end else if AUOM = 5 then begin TempFloat := Round2(CurrFloat); if abs(TempFloat - Round0(CurrFloat)) <= 0.0200001 then CurrFloat := Round0(CurrFloat) else CurrFloat := Round2(CurrFloat) end else CurrFloat := RoundCP(CurrFloat); AText := FloatToStr(CurrFloat); end; except end; dtDate: try AText := DateToStr(StrToDateU(AText)); except end; dtConnectionKind: try AText := GetTubeConnectKindName(StrToInt(AText)); except end; dtStringList: try AText := ReplaceTextInStr(#13+#10, '; ', AText, false, nil); except end; else AText := PropValueToCaption(AText, '', '', ARecord.Values[ADataTypeIndex], AUOM, false); end; end; procedure SetVisibleGridLevel(ALevel: TcxGridLevel; ATabControl: TRzTabControl; AVisible: Boolean); begin ALevel.Visible := AVisible; ATabControl.Tabs[ALevel.Index].Visible := AVisible; end; procedure ShowPopupMenuForControl(AButton: TControl; APopupMenu: TPopupMenu); var BottomLeftPoint: TPoint; begin if (AButton <> nil) and (APopupMenu <> nil) then begin BottomLeftPoint.X := 0; //AButton.Left; BottomLeftPoint.Y := AButton.Height + 1; //AButton.Top + AButton.Height + 1; BottomLeftPoint := AButton.ClientToScreen(BottomLeftPoint); APopupMenu.Popup(BottomLeftPoint.X, BottomLeftPoint.Y); end; end; procedure EnableControl(AControl: TWinControl; AEnable: Boolean); procedure StepEnableControl(AStepControl: TWinControl); var i: Integer; Cntl: TControl; begin if Assigned(AStepControl) then begin for i := 0 to AStepControl.ControlCount - 1 do begin Cntl := AStepControl.Controls[i]; if Cntl is TWinControl then StepEnableControl(TWinControl(Cntl)); end; AStepControl.Enabled := AEnable; end; end; begin try StepEnableControl(AControl); except on E: Exception do AddExceptionToLogEx('EnableControl', E.Message); end; end; procedure LockControl(AControl: TWinControl; ALock: Boolean); var i: Integer; //NotHavecsOpaque: Boolean; begin if (AControl = nil) or (AControl.Handle = 0) then Exit; if ALock then begin if AControl.Showing then SendMessage(AControl.Handle, WM_SETREDRAW, 0, 0); //if Not (csOpaque in AControl.ControlStyle) then // ShowMessage(AControl.Name); //AControl.ControlStyle := AControl.ControlStyle + [csOpaque]; end else if AControl.Showing then begin SendMessage(AControl.Handle, WM_SETREDRAW, 1, 0); RedrawWindow(AControl.Handle, nil, 0, RDW_ERASE or RDW_FRAME or RDW_INVALIDATE or RDW_ALLCHILDREN); end; {if ALock then //for i := 0 to AControl.ComponentCount - 1 do // if AControl.Components[i] is TWinControl then // if TWinControl(AControl.Components[i]).Showing then // LockControl(TWinControl(AControl.Components[i]), ALock); } { if ALock then for i := 0 to AControl.ControlCount - 1 do if AControl.Controls[i] is TWinControl then if TWinControl(AControl.Controls[i]).Showing then LockControl(TWinControl(AControl.Controls[i]), ALock); } end; procedure SetFocusToControl(AControl: TWinControl); begin AControl.SetFocus; ProcessMessagesEx; end; procedure SetCableChannelSectionMaskEditProps(AMaskEditProps: TcxMaskEditProperties); begin AMaskEditProps.MaskKind := emkRegExpr; AMaskEditProps.EditMask := GetDimensionsMask; end; procedure SetCheckToMenuItemList(AMenuItems: TList; ATagToCheck: Integer); var i: Integer; pmItem: TMenuItem; begin for i := 0 to AMenuItems.Count - 1 do begin pmItem := TMenuItem(AMenuItems[i]); pmItem.Checked := (pmItem.Tag = ATagToCheck) and (pmItem.Caption <> '-'); end; end; procedure SetStyleToRZDateTimeEdit(ARzDateTimeEdit: TRzDateTimeEdit); begin ARzDateTimeEdit.CaptionTodayBtn := cBaseCommon54; ARzDateTimeEdit.CaptionClearBtn := cBaseCommon55; //ARzDateTimeEdit.CaptionAM //ARzDateTimeEdit.CaptionPM end; procedure SetStyleToRZColorEdit(AColorEdit: TRzColorEdit); begin AColorEdit.DefaultColorCaption := cColorEdit_DefaultColorCaption; AColorEdit.CustomColorCaption := cColorEdit_CustomColorCaption; AColorEdit.ShowCustomColor := true; AColorEdit.ShowDefaultColor := true; end; procedure ShowHideMenuItems(AMenu: TMenu; AShow: Boolean; AllowAction: Boolean=true); var i: Integer; pmItem: TMenuItem; begin for i := 0 to AMenu.Items.Count - 1 do begin pmItem := AMenu.Items[i]; if AllowAction and Assigned(pmItem.Action) then TAction(pmItem.Action).Visible := AShow; pmItem.Visible := AShow; end; end; procedure ShowHideMenuItemsList(AMenuItems: TList; AShow: Boolean; AllowAction: Boolean=true); var i: Integer; pmItem: TMenuItem; begin if AMenuItems <> nil then for i := 0 to AMenuItems.Count - 1 do begin pmItem := TMenuItem(AMenuItems[i]); if AllowAction and Assigned(pmItem.Action) then TAction(pmItem.Action).Visible := AShow; pmItem.Visible := AShow; end; end; procedure ShowHidePageControlTabls(APageControl: TRzPageControl; AShow: Boolean; APagesToSkip: TList=nil); var i: Integer; begin for i := 0 to APageControl.PageCount - 1 do if (APagesToSkip = nil) or (APagesToSkip.IndexOf(APageControl.Pages[i]) = -1) then APageControl.Pages[i].TabVisible := AShow; end; // Tolik 26/11/2019 -- procedure ShowHintES(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); var HintInfo: THintInfo; h: THintWindow; bhw: TESHintWindow; pt: TPoint; Rect: TRect; //HintInfo: THintInfo; Msg: String; CanShow: Boolean; OldShowHintEvent: TShowHintEvent; begin OldShowHintEvent := Application.OnShowHint; try if GESHintWindow = nil then begin GESHintWindow := TESHintWindow.Create(Application); Application.OnShowHint := OldShowHintEvent; end; GESHintWindow.Hide; if aPoint = nil then GetCursorPos(pt) else pt := aPoint^; bhw := GESHintWindow; Rect := bhw.CalcHintRect(300, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; Rect.Right := Rect.Left + Rect.Right; Rect.Bottom := Rect.Top + Rect.Bottom; // HintInfo.HintControl := nil; HintInfo.HintPos := pt; HintInfo.HideTimeout := aHideTimeout; // bhw.DoShowHint(Msg, CanShow, HintInfo); bhw.ActivateHint(Rect, aMsg); if HintInfo.HideTimeout <> 0 then GTimerESHintHandler := SetTimer(0, 0, HintInfo.HideTimeout, @HideHintES); except on E: Exception do; end; Application.OnShowHint := OldShowHintEvent; end; // { procedure ShowHintES(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); var HintInfo: THintInfo; h: THintWindow; bhw: TESHintWindow; pt: TPoint; Rect: TRect; //HintInfo: THintInfo; Msg: String; CanShow: Boolean; OldShowHintEvent: TShowHintEvent; begin if GESHintWindow = nil then begin OldShowHintEvent := Application.OnShowHint; try GESHintWindow := TESHintWindow.Create(Application); finally Application.OnShowHint := OldShowHintEvent; end; end; GESHintWindow.Hide; if aPoint = nil then GetCursorPos(pt) else pt := aPoint^; bhw := GESHintWindow; Rect := bhw.CalcHintRect(300, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; Rect.Right := Rect.Left + Rect.Right; Rect.Bottom := Rect.Top + Rect.Bottom; // HintInfo.HintControl := nil; HintInfo.HintPos := pt; HintInfo.HideTimeout := aHideTimeout; // bhw.DoShowHint(Msg, CanShow, HintInfo); bhw.ActivateHint(Rect, aMsg); if HintInfo.HideTimeout <> 0 then GTimerESHintHandler := SetTimer(0, 0, HintInfo.HideTimeout, @HideHintES); end; } procedure ShowHintImg(const aImgPath: String; aHideTimeout: Integer; aPoint: PPoint=nil); var pt: TPoint; begin //if F_NormBase.F_ImageShow = nil then // F_NormBase.F_ImageShow := TF_ImageShow.Create(Self, TForm(Self)); if aPoint = nil then GetCursorPos(pt) else pt := aPoint^; F_NormBase.CreateFImageShow.ShowFromFile(aImgPath, @pt); if aHideTimeout <> 0 then GTimerImgHintHandler := SetTimer(0, 0, aHideTimeout, @HideHintImg); end; procedure ShowHintInCursorPos(const AText: String; ATimeInterval: Integer); begin F_NormBase.F_AnswerToQuast.ShowHint(AText, ATimeInterval); end; procedure ShowHintRz(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); var HintInfo: THintInfo; h: THintWindow; bhw: TRzCustomHintWindow; pt: TPoint; Rect: TRect; //HintInfo: THintInfo; Msg: String; CanShow: Boolean; begin {H:=THintWindow.Create(Application.MainForm); H.Brush.Color := clInfoBk; H.Font.Color := clInfoText; H.ParentWindow := Application.MainForm.Handle; //H.ActivateHint(Application.MainForm.ClientRect, aMsg); H.ActivateHint(H.CalcHintRect(300, aMsg, nil), aMsg); Sleep(2000); H.Free; Sleep(2000); } HideHintRz; if aPoint = nil then GetCursorPos(pt) else pt := aPoint^; bhw := F_NormBase.BalloonHints.HintWindow; //bhw.re //bhw.CursorPos := pt; // bhw.Color := clBlack; bhw.Font.Color := clBlack; bhw.Font.Size := 8; Rect := bhw.CalcHintRect(300, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; Rect.Right := Rect.Left + Rect.Right; Rect.Bottom := Rect.Top + Rect.Bottom; // HintInfo.HintControl := nil; HintInfo.HintPos := pt; HintInfo.HideTimeout := aHideTimeout; // bhw.DoShowHint(Msg, CanShow, HintInfo); Rect := bhw.CalcHintRect(300, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; Rect.Right := Rect.Left + Rect.Right; Rect.Bottom := Rect.Top + Rect.Bottom; bhw.DoShowHint(Msg, CanShow, HintInfo); bhw.ActivateHint(Rect, aMsg); //StartHintTimer(HintInfo.HideTimeout, tmHide); //SetTimer(0, 0, HintInfo.HideTimeout, @HintTimerProc); GTimerHintHandler := SetTimer(0, 0, HintInfo.HideTimeout, @HideHintRz); end; function GetHintControlM(Control: TControl): TControl; begin Result := Control; while (Result <> nil) and not Result.ShowHint do Result := Result.Parent; if (Result <> nil) and (csDesigning in Result.ComponentState) then Result := nil; end; procedure ShowHintRzR(const aMsg: String; aHideTimeout: Integer; aPoint: PPoint=nil); var HintInfo: THintInfo; h: THintWindow; bhw: TRzCustomHintWindow; pt: TPoint; Rect: TRect; Msg: String; CanShow: Boolean; P: TPoint; ctrl: TControl; begin HideHintRz; //exit; if aPoint = nil then GetCursorPos(pt) else pt := aPoint^; bhw := F_NormBase.BalloonHints.HintWindow; // HintInfo.HintColor := clRed; // bhw.Color := clRed; bhw.Font.Name := 'Tahoma'; // Tolik 24/09/2021 -- bhw.Font.Color := clRed; bhw.Font.Size := 10; Rect := bhw.CalcHintRect(320, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; //Tolik 27/09/2021 -- //Rect.Right := Rect.Left + Rect.Right + 5; Rect.Right := Rect.Left + Rect.Right + 15; // Rect.Bottom := Rect.Top + Rect.Bottom + 15; // HintInfo.HintControl := nil; { GetCursorPos(P); ctrl := FindDragTarget(P, True); if ctrl <> nil then ctrl.ShowHint := true; HintInfo.HintControl := GetHintControlM(ctrl); } HintInfo.HintPos := pt; HintInfo.HideTimeout := aHideTimeout; HintInfo.HintData := nil; // bhw.DoShowHint(Msg, CanShow, HintInfo); Rect := bhw.CalcHintRect(320, aMsg, nil); Rect.Left := pt.X; Rect.Top := pt.Y; //Tolik 27/09/2021 -- //Rect.Right := Rect.Left + Rect.Right + 5; Rect.Right := Rect.Left + Rect.Right + 15; // Rect.Bottom := Rect.Top + Rect.Bottom + 15; bhw.DoShowHint(Msg, CanShow, HintInfo); bhw.ActivateHint(Rect, aMsg); // Application.ActivateHint(Rect, aMsg); //Application.ActivateHint(pt); //HintInfo.HintColor := clBlack; //bhw.Font.Color := clBlack; //bhw.Font.Size := 8; GTimerHintHandler := SetTimer(0, 0, HintInfo.HideTimeout, @HideHintRz); end; procedure HideHintES; begin if GTimerESHintHandler <> 0 then begin KillTimer(0, GTimerESHintHandler); GTimerESHintHandler := 0; end; SetWindowPos(GESHintWindow.Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW); end; procedure HideHintImg; begin if GTimerImgHintHandler <> 0 then begin KillTimer(0, GTimerImgHintHandler); GTimerImgHintHandler := 0; end; if F_NormBase.F_ImageShow <> nil then begin if F_NormBase.F_ImageShow.Visible then F_NormBase.F_ImageShow.Hide; end; end; procedure HideHintRz; begin if GTimerHintHandler <> 0 then begin KillTimer(0, GTimerHintHandler); GTimerHintHandler := 0; SetWindowPos( F_NormBase.BalloonHints.HintWindow.Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW); F_NormBase.BalloonHints.HintWindow.Font.Color := ClBlack; F_NormBase.BalloonHints.HintWindow.Font.Size := 8; end; end; procedure HideHintInCursorPos; begin F_NormBase.F_AnswerToQuast.HideHint; end; function IsVisibleHintES: Boolean; begin Result := false; if GESHintWindow <> nil then //Result := GESHintWindow.Visible; Result := IsWindowVisible(GESHintWindow.Handle); end; procedure ValidateActiveFormControl(AForm: TForm); var Control: TWinControl; begin if Assigned(AForm) then if AForm.ActiveControl <> nil then begin Control := AForm.ActiveControl; //*** cxEdit if Control is TcxCustomInnerTextEdit then begin if TcxCustomInnerTextEdit(Control).Parent is TcxCustomEdit then TcxCustomEdit(Control.Parent).ValidateEdit(false); end else //*** cxRadioGroup if Control is TcxCustomRadioGroupButton then begin if TcxCustomRadioGroupButton(Control).Parent is TcxRadioGroup then TcxRadioGroup(Control.Parent).ValidateEdit(false); end else //*** cxComboBox if Control is TcxCustomComboBoxInnerEdit then begin if TcxCustomComboBoxInnerEdit(Control).Parent is TcxCustomEdit then TcxCustomEdit(Control.Parent).ValidateEdit(false); end else if Control.Parent <> nil then begin //if Control.Parent is TcxMemo then // TcxMemo(Control.Parent).ValidateEdit(false); if Control.Parent is TcxCustomEdit then TcxCustomEdit(Control.Parent).ValidateEdit(false); end; // OnExitEvent if Control.Parent <> nil then begin if Control.Parent is TcxTextEdit then begin if Assigned(TcxTextEdit(Control.Parent).OnExit) then TcxTextEdit(Control.Parent).OnExit(Control.Parent); end else if Control.Parent is TcxMemo then begin if Assigned(TcxMemo(Control.Parent).OnExit) then TcxMemo(Control.Parent).OnExit(Control.Parent); end; end; end; end; procedure EnableTimerWithOrder(ATimer: TTimer; AEnable: Boolean; AHightPriority: Boolean = false); begin if AEnable <> ATimer.Enabled then begin GTimerListToHandle.Remove(ATimer); if AEnable then begin ATimer.Enabled := true; if AHightPriority then GTimerListToHandle.Insert(0, ATimer) else GTimerListToHandle.Add(ATimer); end else begin ATimer.Enabled := false; end; end; end; function IsOtherTimerToHandleInOrder(ATimer: TTimer): Boolean; begin Result := false; if (GTimerListToHandle <> nil) and (GTimerListToHandle.IndexOf(ATimer) > 0) then Result := true; end; procedure RestartTimer(ATimer: TTimer); begin if Assigned(ATimer) then begin if ATimer.Enabled then ATimer.Enabled := false; ATimer.Enabled := true; end; end; procedure TerminateApplicationWithMessage(AMessage: String); begin ShowMessageByType(FSCS_Main.Handle, smtDisplay, AMessage, Application.Title, MB_OK or MB_ICONSTOP); //MessageDlg(AMessage, mtError, [mbOk], 0); FSCS_Main.aClose.Execute; end; function GetComputerNetName: string; var buffer: array[0..255] of char; size: dword; begin size := 256; if GetComputerName(buffer, size) then Result := buffer else Result := ''; end; function GetIPAddress: String; var wVerReq: WORD; //wsaData: TWSAData; i: pchar; //h: PHostEnt; c: array[0..128] of char; begin try (* wVerReq := $101; WSAStartup(wVerReq, wsaData); {Получаем хост (имя) компа} GetHostName(@c, 128); h := GetHostByName(@c); //h^.h_Name; //Host отображает хост(имя) компьютера {Достаем IP} Result := iNet_ntoa(PInAddr(h^.h_addr_list^)^); WSACleanup; *) except on E: Exception do AddExceptionToLog('GetIPAddress: '+E.Message); end; end; function GetIPAddressFromName(AName: string): String; const WINSOCK_VERSION = $0101; var WSAData: TWSAData; p: PHostEnt; AnsiName: AnsiString; // Tolik 12/08/2019 -- begin AnsiName := AnsiString(AName); // Tolik 12/08/2019 -- Result := ''; if CheckIsIPName(AName) then Result := AName else begin WSAStartup(WINSOCK_VERSION, WSAData); //p := GetHostByName(PAnsiChar(AName)); p := GetHostByName(PAnsiChar(AnsiName)); // Tolik 12/08/2019 -- Result := inet_ntoa(PInAddr(p.h_addr_list^)^); WSACleanup; end; end; { function GetTFormByChildObj(AChildObj: TObject): TObject; var CurrObj: TObject; begin Result := nil; CurrObj := AChildObj; while end; } procedure GetZeroMem(var P; ASize: Integer); begin GetMem(Pointer(P), ASize); ZeroMemory(Pointer(P), ASize); end; procedure NewData(var AObjectData: PObjectData; ATreeType: TTreeType); begin //New(AObjectData); GetZeroMem(AObjectData, SizeOf(TObjectData)); //AObjectData.HasChildren := false; AObjectData.TreeType := ATreeType; AObjectData.FontColor := -1; end; function GetMakeEditByFormMode(AFormMode: TFormMode): TMakeEdit; begin Result := meMake; case AFormMode of fmMake: Result := meMake; fmEdit: Result := meEdit; end; end; procedure AddStringToStringListOnce(AStringList: TStringList; const AString: String); begin if (AString <> '') and (AStringList.IndexOf(AString) = -1) then AStringList.Add(AString); end; function CreateStringListSorted: TStringList; begin Result := TStringList.Create; Result.Sorted := true; end; // ##### В строке убрать концовку, что отображает количество в скобках procedure CutColFromStr(var AStr: String); var Len, i: Integer; begin Len := Length(AStr); for i := Len downto 1 do if AStr[i] = '[' then begin SetLength(AStr, i-3); Break; end; end; function FindCypherTytleAtStringList(AStringList: TStringList; AAllCypher: String; var ATytle: String): Boolean; var i, j: Integer; MaxSymbolCnt: Integer; LastTitle: String; CurrSymbolCnt: Integer; CurrString: String; CurrTitle: String; CurrStringLength: Integer; AllCypherLength: Integer; CurrCharCount: Integer; begin Result := false; MaxSymbolCnt := 0; LastTitle := ''; AllCypherLength := Length(AAllCypher); for i := 0 to AStringList.Count - 1 do begin CurrString := AStringList[i]; CurrSymbolCnt := 0; CurrStringLength := Length(CurrString); CurrTitle := ''; CurrCharCount := 0; if CurrStringLength < AllCypherLength then CurrCharCount := CurrStringLength else CurrCharCount := AllCypherLength; for j := 1 to CurrCharCount do begin if CurrString[j] = AAllCypher[j] then begin CurrTitle := CurrTitle + CurrString[j]; Inc(CurrCharCount); if CurrCharCount > MaxSymbolCnt then begin MaxSymbolCnt := CurrCharCount; LastTitle := CurrTitle; if Result = false then Result := true; end; end else Break; ///// BREAK ///// end; end; if Result = true then ATytle := LastTitle; end; procedure AddRecordToListAsSorted(AList: TList; ARecPointer: Pointer; ASortFldOffset: Integer); var NewIndex: Integer; RecBoud: Pointer; AddingFldValue: Integer; Prop: TProperty; ptrProp: Pointer; function GetIntValueFromRecord(APointer: Pointer): Integer; var ptrInt: ^Integer; begin Result := -1; ptrInt := Pointer(Integer(APointer) + ASortFldOffset); Result := ptrInt^; end; function FindIndex(AMinIndex, AMaxIndex: Integer): Integer; var IndexMiddle: Integer; IndexLeft: Integer; IndexRight: Integer; RecOnMidle: Pointer; RecLeft: Pointer; RecRight: Pointer; MiddleValue: Integer; begin Result := -1; IndexMiddle := AMinIndex + ((AMaxIndex - AMinIndex) div 2); if (IndexMiddle >= AMinIndex) and (IndexMiddle <= AMaxIndex) then begin RecOnMidle := AList[IndexMiddle]; if RecOnMidle <> nil then begin MiddleValue := GetIntValueFromRecord(RecOnMidle); if AddingFldValue = MiddleValue then Result := IndexMiddle else begin RecLeft := nil; RecRight := nil; IndexLeft := -1; IndexRight := -1; if IndexMiddle - 1 >= AMinIndex then begin IndexLeft := IndexMiddle - 1; RecLeft := AList[IndexLeft]; if RecLeft <> nil then if (AddingFldValue >= GetIntValueFromRecord(RecLeft)) and (AddingFldValue <= MiddleValue) then Result := IndexLeft + 1; end; if Result = -1 then if IndexMiddle + 1 <= AMaxIndex then begin IndexRight := IndexMiddle + 1; RecRight := AList[IndexRight]; if RecRight <> nil then if (AddingFldValue >= MiddleValue) and (AddingFldValue <= GetIntValueFromRecord(RecRight)) then Result := IndexRight; end; if Result = -1 then if AddingFldValue < MiddleValue then // Ищем индекс в левой части Result := FindIndex(AMinIndex, IndexMiddle) else if AddingFldValue > MiddleValue then // Ищем индекс в правой части Result := FindIndex(IndexMiddle, AMaxIndex); end; end; end; end; begin NewIndex := -1; if AList.Count = 0 then NewIndex := 0 else begin AddingFldValue := GetIntValueFromRecord(ARecPointer); RecBoud := AList[AList.Count - 1]; if RecBoud <> nil then if AddingFldValue >= GetIntValueFromRecord(RecBoud) then NewIndex := AList.Count; if NewIndex = -1 then begin RecBoud := AList[0]; if RecBoud <> nil then if AddingFldValue <= GetIntValueFromRecord(RecBoud) then NewIndex := 0; end; if NewIndex = -1 then NewIndex := FindIndex(0, AList.Count - 1); end; if NewIndex <> -1 then AList.Insert(NewIndex, ARecPointer) else raise Exception.Create('Index not found'); end; procedure ClearAndDisposeList(AList: Tlist); var i: Integer; begin if AList = nil then Exit; ///// EXIT ///// for i := 0 to AList.Count - 1 do begin if AList.Items[i] <> nil then Dispose(AList.Items[i]); end; AList.Clear; end; procedure FreeAndDisposeList(AList: Tlist); var i: Integer; begin if AList = nil then Exit; ///// EXIT ///// for i := 0 to AList.Count - 1 do begin if AList.Items[i] <> nil then Dispose(AList.Items[i]); end; FreeAndNil(AList); end; // ##### Полностью очистить List ##### procedure FreeList(AList: Tlist); var i: Integer; LCount : Integer; begin if AList = nil then Exit; ///// EXIT ///// for i := 0 to AList.Count - 1 do begin if AList.Items[i] <> nil then FreeMem(AList.Items[i]); end; //i := 0; //LCount := AList.Count; //while i <= LCount - 1 do //begin // FreeMem(AList.Items[i]); // Inc(i); //end; FreeAndNil(AList); end; procedure ClearList(AList : TList); var Count : Integer; i : Integer; Obj : Pointer; begin if AList = nil then Exit; i := 0; Count := AList.Count; while i <= Count - 1 do begin Obj := AList.Items[i]; FreeMem(Obj); Inc(i); end; AList.Clear; end; // Tolik 24/07/2018 -- Procedure FreeObjectList(aList: TList); var i: Integer; Obj : Pointer; begin if aList = Nil then exit; for i := 0 to aList.Count - 1 do begin Obj := aList[i]; TObject(Obj).Free; end; aList.Free; end; // function CheckEqualIntLists(AList1, AList2: TIntList): Boolean; var i: Integer; begin Result := false; if AList1.Count = AList2.Count then begin Result := true; for i := 0 to AList1.Count - 1 do if AList1[i] <> AList2[i] then begin Result := false; Break; //// BREAK //// end; end; end; procedure AssignListItems(ASrcList, ATrgList: TList); var i: Integer; begin if Assigned(ASrcList) and Assigned(ATrgList) then for i := 0 to ASrcList.Count - 1 do ATrgList.Add(ASrcList[i]); end; procedure RemoveFromListItems(ADstList, AListItemsToRemove: TList); var i: Integer; begin if Assigned(ADstList) and Assigned(AListItemsToRemove) then for i := 0 to AListItemsToRemove.Count - 1 do ADstList.Remove(AListItemsToRemove[i]); end; function CheckNoIDinList(ACheckID: Integer; AList: TList): Boolean; var i: Integer; begin Result := true; if AList <> nil then for i := 0 to AList.Count - 1 do if Integer(AList.Items[i]^) = ACheckID then begin Result := false; Break; end; end; function RemoveFromStringList(AStringList: TStringList; const AString: String): Integer; var RemoveIndex: Integer; begin Result := -1; if Assigned(AStringList) then begin RemoveIndex := AStringList.IndexOf(AString); if RemoveIndex <> -1 then begin AStringList.Delete(RemoveIndex); Result := RemoveIndex; end; end; end; // ##### Проверяет возможно ли соединить интерфейсы ##### function CheckInterfForUnion(AInterf1, Ainterf2: TObject; AInterf1Form, AInterf2Form: TForm; {AConnectKinds: TConnectKind;} AConnectType: TConnectType; AKolvoInterf1, AKolvoInterf2: PInteger; ASkipElements: TCheckInterfForUnionElements=[]): TCheckInterfForUnionResult; var ContinueToCheck: Boolean; IDInterfStr1: String; IDInterfStr2: String; isMultiple1: Boolean; isMultiple2: Boolean; ColConn1: Integer; ColConn2: Integer; i, j: Integer; Interfac: TSCSInterface; IOfIRel: TSCSIOfIRel; function GetisMultiple(AInterf: TSCSInterface): Boolean; begin Result := false; //SetSQLToQuery(DM.scsQSelect, ' select multiple from interface_relation where id = '''+IntToStr(AInterfRel)+''' '); case AInterf.Multiple of 0: Result := false; 1: Result := true; end; end; { function GetColConn(AInterfRel: Integer): Integer; var InterfRelStr: String; begin with F_ProjMan do begin Result := 0; InterfRelStr := IntToStr(AInterfRel); Result := DM.GetIOfIRelCountByFulter('(id_interf_rel = '''+InterfRelStr+''') or '+ '(id_interf_to = '''+InterfRelStr+''')', false); end; end; } (* function GetColConnWithNoMultiple(AInterfRel: integer): Integer; var InterfRelStr: String; PartSQL: String; begin with F_ProjMan do begin Result := 0; PartSQL := ' in (select id from interface_relation where multiple = ''0'') '; InterfRelStr := IntToStr(AInterfRel); {SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_rel = '''+InterfRelStr+''') and '+ ' (id_interf_to'+PartSQL+' ) ) or '+ ' ((id_interf_to = '''+InterfRelStr+''') and '+ ' (id_interf_rel'+PartSQL+' ) )'); Result := DM.scsQSelect.FN('Count').AsInteger;} SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_rel = '''+InterfRelStr+''') and '+ ' (id_interf_to'+PartSQL+' ) ) '); Result := DM.scsQSelect.GetFNAsInteger('Cnt'); SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_to = '''+InterfRelStr+''') and '+ ' (id_interf_rel'+PartSQL+' ) ) '); Result := Result + DM.scsQSelect.GetFNAsInteger('Cnt'); end end; *) begin Result := chrFail; try ContinueToCheck := true; //12.03.2009 IDInterfStr1 := IntToStr(TSCSInterface(AInterf1).ID); //12.03.2009 IDInterfStr2 := IntToStr(TSCSInterface(AInterf2).ID); with F_ProjMan do begin //*** Проверить нет ли такого соединения {if DM.GetIOfIRelCountByFulter('((id_interf_rel = '''+IDInterfStr1+''') and '+ '(id_interf_to = '''+IDInterfStr2+''')) or '+ '((id_interf_to = '''+IDInterfStr1+''') and '+ '(id_interf_rel = '''+IDInterfStr2+'''))', true) > 0 then begin ContinueToCheck := false; Result := chrInterfConnected; end; } {if DM.GetIOfIRelCountByFulter('(id_interf_rel = '''+IDInterfStr1+''') and '+ '(id_interf_to = '''+IDInterfStr2+''')', true) > 0 then begin ContinueToCheck := false; Result := chrInterfConnected; end else if DM.GetIOfIRelCountByFulter('(id_interf_rel = '''+IDInterfStr2+''') and '+ '(id_interf_to = '''+IDInterfStr1+''')', true) > 0 then begin ContinueToCheck := false; Result := chrInterfConnected; end; } if Not(ciueInterfConnected in ASkipElements) then begin if AInterf1Form <> AInterf2Form then begin if Assigned(TSCSInterface(AInterf1).IOfIRelOut) then for i := 0 to TSCSInterface(AInterf1).IOfIRelOut.Count - 1 do begin IOfIRel := TSCSIOfIRel(TSCSInterface(AInterf1).IOfIRelOut[i]); if IOfIRel.IDInterfTo = TSCSInterface(AInterf2).ID then begin ContinueToCheck := false; Result := chrInterfConnected; Break; ///// BREAK ///// end; end; if ContinueToCheck then if Assigned(TSCSInterface(AInterf2).IOfIRelOut) then for i := 0 to TSCSInterface(AInterf2).IOfIRelOut.Count - 1 do begin IOfIRel := TSCSIOfIRel(TSCSInterface(AInterf2).IOfIRelOut[i]); if IOfIRel.IDInterfTo = TSCSInterface(AInterf1).ID then begin ContinueToCheck := false; Result := chrInterfConnected; Break; ///// BREAK ///// end; end; end else begin if (TSCSInterface(AInterf1).ConnectedInterfaces.IndexOf(TSCSInterface(AInterf2)) <> -1) or (TSCSInterface(AInterf2).ConnectedInterfaces.IndexOf(TSCSInterface(AInterf1)) <> -1) then begin ContinueToCheck := false; Result := chrInterfConnected; end; end; end; if Not CheckGender(TSCSInterface(AInterf1), TSCSInterface(Ainterf2), AConnectType{, AConnectKinds}) then begin //ContinueToCheck := false; Result := chrFailGenders; Exit; ///// EXIT ///// end; //if AConnectType = cntUnion then if (TSCSInterface(Ainterf1).SideSection <> '') and (TSCSInterface(Ainterf2).SideSection <> '') then begin //if TSCSInterface(Ainterf1).SideSection <> TSCSInterface(Ainterf2).SideSection then //if (Pos(TSCSInterface(Ainterf1).SideSection, TSCSInterface(Ainterf2).SideSection) = 0) and // (Pos(TSCSInterface(Ainterf2).SideSection, TSCSInterface(Ainterf1).SideSection) = 0) then if Not CheckStrForCommonParam(TSCSInterface(Ainterf1).SideSection, TSCSInterface(Ainterf2).SideSection) then begin Result := chrFailSideSection; Exit; ///// EXIT ///// end; end; if Not CheckInterf(TSCSInterface(Ainterf1), TSCSInterface(Ainterf2), AConnectType, AKolvoInterf1, AKolvoInterf2) then begin //ContinueToCheck := false; Result := chrFailInterfaces; Exit; ///// EXIT ///// end; //if (AInterf1.IsLineCompon = biTrue) and (AInterf2.IsLineCompon = biTrue) then // if (AInterf1.Side = stNoneSide) and (AInterf2.Side = stNoneSide) then // if (AInterf1.Gender = AInterf2.Gender) then // begin // ContinueToCheck := false; // Result := chrFailGenders; // end; if Not ContinueToCheck then Exit; /////// EXIT //////// if AConnectType = cntUnion then begin isMultiple1 := TSCSInterface(AInterf1).Multiple = biTrue; //12.03.2009 isMultiple1 := TSCSInterface(AInterf1).GetIsMultiple; //GetisMultiple(AInterf1); isMultiple2 := TSCSInterface(AInterf2).Multiple = biTrue; //12.03.2009 isMultiple2 := TSCSInterface(AInterf2).GetIsMultiple; //GetisMultiple(AInterf2); // IGOR 2017-05-23 //проверить - если линейный и неразьемный а второй точечный - то подключать только к неразьемному //или первый точечный а второй линейный и неразьемный то только к неразьемному тоже может подключиться if ( (TSCSInterface(AInterf1).IsLineCompon = 1) and (TSCSInterface(AInterf1).Kind = ikNoSplit) and (TSCSInterface(AInterf2).IsLineCompon = 0) and (TSCSInterface(AInterf2).Kind = ikSplit) ) or ( (TSCSInterface(AInterf2).IsLineCompon = 1) and (TSCSInterface(AInterf2).Kind = ikNoSplit) and (TSCSInterface(AInterf1).IsLineCompon = 0) and (TSCSInterface(AInterf1).Kind = ikSplit) ) then begin Result := chrFail; exit; end; if ((TSCSInterface(AInterf1).IsLineCompon = 1) and (TSCSInterface(AInterf1).Gender = gtMale) and (TSCSInterface(AInterf2).IsLineCompon = 0) and (TSCSInterface(AInterf2).Gender = gtFeMale) and ((isMultiple1 and isMultiple2)or((Not isMultiple1) and isMultiple2))) or ((TSCSInterface(AInterf2).IsLineCompon = 1) and (TSCSInterface(AInterf2).Gender = gtMale) and (TSCSInterface(AInterf1).IsLineCompon = 0) and (TSCSInterface(AInterf1).Gender = gtFeMale) and (Not isMultiple2) and isMultiple1) then begin if isMultiple1 = false then begin if (TSCSInterface(AInterf1).Kolvo <= TSCSInterface(AInterf1).KolvoBusy) then //or //(TSCSInterface(AInterf2).Kolvo <= TSCSInterface(AInterf2).KolvoBusy) then Result := chrBusy else Result := chrSuccess; end else begin ColConn1 := TSCSInterface(AInterf1).GetColJoinedWithNoMultiple; ColConn2 := TSCSInterface(AInterf2).GetColJoinedWithNoMultiple; if (ColConn1 = 0) and (ColConn2 = 0) then Result := chrSuccess else Result := chrSameMult; end; end else begin if isMultiple1 = isMultiple2 then begin if isMultiple1 = false then begin if (TSCSInterface(AInterf1).Kolvo <= TSCSInterface(AInterf1).KolvoBusy) or (TSCSInterface(AInterf2).Kolvo <= TSCSInterface(AInterf2).KolvoBusy) then Result := chrBusy else Result := chrSuccess; end else begin ColConn1 := TSCSInterface(AInterf1).GetColJoinedWithNoMultiple; ColConn2 := TSCSInterface(AInterf2).GetColJoinedWithNoMultiple; if (ColConn1 = 0) and (ColConn2 = 0) then Result := chrSuccess else Result := chrSameMult; end; end; if isMultiple1 <> isMultiple2 then begin ColConn1 := TSCSInterface(AInterf1).ConnectedInterfaces.Count; //GetColConn(TSCSInterface(AInterf1).ID); ColConn2 := TSCSInterface(AInterf2).ConnectedInterfaces.Count; //GetColConn(TSCSInterface(AInterf2).ID); if (ColConn1 = 0) and (ColConn2 = 0) then Result := chrSuccess else Result := chrVariousMult; end; end; end else Result := chrSuccess; end; except on E: Exception do AddExceptionToLog('CheckInterfForUnion: '+E.Message); end; end; { procedure RemoveInterfFromAllReferences(AInterface: TObject); var i: Integer; ptrConnectedInterf: TSCSInterface; procedure DisJoin(AInterf1, AInterf2: TSCSInterface); var j: Integer; ptrIOfIRel: PIOfIRel; begin if (AInterf1 = nil) or (AInterf2 = nil) then Exit; ///// EXIT ///// if Assigned(AInterf1.IOfIRelOut) then begin for j := 0 to AInterf1.IOfIRelOut.Count - 1 do begin ptrIOfIRel := AInterf1.IOfIRelOut[j]; if ptrIOfIRel.InterfaceTo = AInterf2 then begin FreeMem(ptrIOfIRel); AInterf1.IOfIRelOut[j] := nil; end; end; AInterf1.IOfIRelOut.Pack; end; end; begin if AInterface <> nil then if Assigned(AInterface.ConnectedInterfaces) then begin for i := 0 to TSCSInterface(AInterface).ConnectedInterfaces.Count - 1 do begin ptrConnectedInterf := TSCSInterface(AInterface).ConnectedInterfaces[i]; AInterface.ConnectedInterfaces[i] := nil; if Assigned(ptrConnectedInterf.ConnectedInterfaces) then ptrConnectedInterf.ConnectedInterfaces.Remove(AInterface); DisJoin(AInterface, ptrConnectedInterf); DisJoin(ptrConnectedInterf, AInterface); end; AInterface.ConnectedInterfaces.Pack; end; end; } (* // ##### Проверяет возможно ли соединить интерфейсы ##### function CheckInterfForUnion(AInterf1, Ainterf2: TInterface; AConnectKinds: TConnectKind): TCheckInterfForUnionResult; var ContinueToCheck: Boolean; IDInterfStr1: String; IDInterfStr2: String; isMultiple1: Boolean; isMultiple2: Boolean; ColConn1: Integer; ColConn2: Integer; function GetisMultiple(AInterf: TInterface): Boolean; begin Result := false; //SetSQLToQuery(DM.scsQSelect, ' select multiple from interface_relation where id = '''+IntToStr(AInterfRel)+''' '); case AInterf.Multiple of 0: Result := false; 1: Result := true; end; end; function GetColConn(AInterfRel: Integer): Integer; var InterfRelStr: String; begin with F_ProjMan do begin Result := 0; InterfRelStr := IntToStr(AInterfRel); SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where (id_interf_rel = '''+InterfRelStr+''') or '+ ' (id_interf_to = '''+InterfRelStr+''') '); Result := DM.scsQSelect.GetFNAsInteger('Cnt'); end; end; function GetColConnWithNoMultiple(AInterfRel: integer): Integer; var InterfRelStr: String; PartSQL: String; begin with F_ProjMan do begin Result := 0; PartSQL := ' in (select id from interface_relation where multiple = ''0'') '; InterfRelStr := IntToStr(AInterfRel); {SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_rel = '''+InterfRelStr+''') and '+ ' (id_interf_to'+PartSQL+' ) ) or '+ ' ((id_interf_to = '''+InterfRelStr+''') and '+ ' (id_interf_rel'+PartSQL+' ) )'); Result := DM.scsQSelect.FN('Count').AsInteger;} SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_rel = '''+InterfRelStr+''') and '+ ' (id_interf_to'+PartSQL+' ) ) '); Result := DM.scsQSelect.GetFNAsInteger('Cnt'); SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_to = '''+InterfRelStr+''') and '+ ' (id_interf_rel'+PartSQL+' ) ) '); Result := Result + DM.scsQSelect.GetFNAsInteger('Cnt'); end end; begin Result := chrFail; try ContinueToCheck := true; IDInterfStr1 := IntToStr(AInterf1.ID); IDInterfStr2 := IntToStr(AInterf2.ID); with F_ProjMan do begin //*** Проверить нет ли такого соединения SetSQLToQuery(DM.scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where ((id_interf_rel = '''+IDInterfStr1+''') and '+ ' (id_interf_to = '''+IDInterfStr2+''')) or '+ ' ((id_interf_to = '''+IDInterfStr1+''') and '+ ' (id_interf_rel = '''+IDInterfStr2+''')) '); if DM.scsQSelect.GetFNAsInteger('Cnt') > 0 then begin ContinueToCheck := false; Result := chrInterfConnected; end; if Not CheckInterf(Ainterf1, Ainterf2) then begin ContinueToCheck := false; Result := chrFailInterfaces; end; if Not CheckGender(AInterf1.Gender, Ainterf2.Gender, AConnectKinds) then begin ContinueToCheck := false; Result := chrFailGenders; end; if Not ContinueToCheck then Exit; /////// EXIT //////// isMultiple1 := GetisMultiple(AInterf1); isMultiple2 := GetisMultiple(AInterf2); if isMultiple1 = isMultiple2 then begin if isMultiple1 = false then begin if (AInterf1.IsBusy = biTrue) or (AInterf2.IsBusy = biTrue) then Result := chrBusy else Result := chrSuccess; end else begin ColConn1 := GetColConnWithNoMultiple(AInterf1.ID); ColConn2 := GetColConnWithNoMultiple(AInterf2.ID); if (ColConn1 = 0) and (ColConn2 = 0) then Result := chrSuccess else Result := chrSameMult; end; end; if isMultiple1 <> isMultiple2 then begin ColConn1 := GetColConn(AInterf1.ID); ColConn2 := GetColConn(AInterf2.ID); if (ColConn1 = 0) and (ColConn2 = 0) then Result := chrSuccess else Result := chrVariousMult; end; end; except on E: Exception do AddExceptionToLog('CheckInterfForUnion: '+E.Message); end; end; *) function CheckInterfAccordInList(AList: TList; AIDInterf1, AIDInterf2, AIsLine1, AIsLine2: Integer): Boolean; var i: Integer; ptrNoInterfAccord: PInterfaceAccordance; begin Result := false; if Assigned(AList) then for i := 0 to AList.Count - 1 do begin ptrNoInterfAccord := AList[i]; with ptrNoInterfAccord^ do if ((IDInterface1 = AIDInterf1) and (IDInterface2 = AIDInterf2) and (IsLine1 = AIsLine1) and (IsLine2 = AIsLine2)) or ((IDInterface1 = AIDInterf2) and (IDInterface2 = AIDInterf1) and (IsLine1 = AIsLine2) and (IsLine2 = AIsLine1)) then begin Result := true; Break; ///// BREAK ///// end; end; end; // ##### Делает задержку ##### procedure Delay(AmkSeconds: Integer); var // Tolik 28/08/2019 -- //StartTick: Cardinal; //CurrTick: Cardinal; StartTick, CurrTick: DWord; // begin StartTick := GetTickCount; CurrTick := StartTick; while Abs(CurrTick - StartTick) < AmkSeconds do CurrTick := GetTickCount; end; // ##### Обеспечивает прокрутку дерева по вертикале ##### procedure ScrollTreeOnDrag(ATreeView: TTreeView; AX, AY: Integer; AScrollSleep: Integer = 40); var MinRange: Integer; MaxRange: Integer; Pos : Integer; begin GetScrollRange(ATreeView.Handle, SB_VERT, MinRange, MaxRange); Pos := GetScrollPos(ATreeView.Handle, SB_VERT); if (AY <= ATreeView.Top ) and (Pos > Minrange) then begin ATreeView.Perform(WM_VSCROLL, MakeWParam(SB_LINEUP, 0) ,0); ATreeView.Repaint; Delay(AScrollSleep); end; if (AY >= ATreeView.Height - 20) and (Pos < MaxRange) then begin ATreeView.Perform(WM_VSCROLL, MakeWParam(SB_LINEDOWN, 0) ,0); ATreeView.Repaint; Delay(AScrollSleep); end; end; procedure ScrollTreeOnDragByRect(AForm: TForm; ATreeView: TTreeView); const MaxBound = 40; var //BoundHSize: Integer; //BoundVSize: Integer; BoundSize: Integer; PosXYBySrc: TPoint; PosXY: TPoint; TimerInterval: Integer; begin GHandleWindowForTreeViewScroll := AForm.Handle; GTreeViewToScrollOnDrag := ATreeView; KillTimer(GHandleWindowForTreeViewScroll, TimerIDTreeViewScrolling); GTreeViewLastRepaintTime := 0; //*** Определить растояние от верхнего/нижнего левого/правого края дерева BoundSize := 0; GetCursorPos(PosXYBySrc); PosXY := GTreeViewToScrollOnDrag.ScreenToClient(PosXYBySrc); //*** Вертикальный скрол имеет высший приоритет if PosXY.Y < (GTreeViewToScrollOnDrag.Height div 2) then begin BoundSize := PosXY.Y; GTreeViewScrollType := stVUp; end else begin BoundSize := GTreeViewToScrollOnDrag.Height - PosXY.Y; GTreeViewScrollType := stVDown; end; //*** Проверить горизонталь if (BoundSize <= 0) or (BoundSize > MaxBound) then begin BoundSize := 0; if PosXY.X < (GTreeViewToScrollOnDrag.Width div 2) then begin BoundSize := PosXY.X; GTreeViewScrollType := stHLeft; end else begin BoundSize := GTreeViewToScrollOnDrag.Width - PosXY.X; GTreeViewScrollType := stHRight; end; end; if (BoundSize > 0) and (BoundSize <= MaxBound) then begin TimerInterval := BoundSize * 2; if TimerInterval > 0 then SetTimer(GHandleWindowForTreeViewScroll, TimerIDTreeViewScrolling, TimerInterval, @HandleTimerTreeViewScrolling); end; end; // ##### Определяет, стоит ли указатель мыши на ветви указанное время ##### function WaitBeforeDragExpand(AmkSecond: Integer; ATargetNode: TTreeNode): Boolean; begin Result := false; GDragCurrTickCount := GetTickCount; if GPrevDragNode <> ATargetNode then GDragPrevTickCount := GetTickCount; if ( ATargetNode <> nil) then if ( Abs(GDragCurrTickCount - GDragPrevTickCount) >= AmkSecond) then if( ATargetNode.Count > 0) and (ATargetNode.Expanded = false) then Result := true; GPrevDragNode := ATargetNode; end; function ExpandCursorNodeByTimer(AForm: TForm; ATreeView: TTreeView; AFirstCursorNode: TTreeNode; ATimerInterval: Integer): Boolean; begin Result := false; GHandleWindowForNodeToExpand := AForm.Handle; GTreeViewWithNodeToExpand := ATreeView; GFirstCursorNodeToExpand := AFirstCursorNode; KillTimer(GHandleWindowForNodeToExpand, TimerIDExpandNode); SetTimer(GHandleWindowForNodeToExpand, TimerIDExpandNode, ATimerInterval, @HandleTimerExpandNode); end; procedure HandleTimerExpandNode; var LastCursorNode: TTreeNode; PosXYBySrc: TPoint; PosXY: TPoint; begin KillTimer(GHandleWindowForNodeToExpand, TimerIDExpandNode); LastCursorNode := nil; GetCursorPos(PosXYBySrc); PosXY := GTreeViewWithNodeToExpand.ScreenToClient(PosXYBySrc); LastCursorNode := GTreeViewWithNodeToExpand.GetNodeAt(PosXY.X, PosXY.Y); if GFirstCursorNodeToExpand = LastCursorNode then begin LastCursorNode.Expanded := true; GTreeViewWithNodeToExpand.Repaint; end; end; procedure HandleTimerTreeViewScrolling; const StepSize = 10; var DeltaX: Integer; DeltaY: Integer; MinRange: Integer; MaxRange: Integer; Pos : Integer; ScrollBarType: Integer; MessageType: Integer; ScrollBarCommoand: Integer; // Tolik 28/08/2019 -- //CurrTickCount: Integer; CurrTickCount: DWord; // //KeyState: SmallInt; CanScroll: Boolean; begin if GTreeViewToScrollOnDrag <> nil then begin DeltaX := 0; DeltaY := 0; ScrollBarType := -1; MessageType := -1; ScrollBarCommoand := -1; case GTreeViewScrollType of stVUp: begin DeltaY := StepSize * -1; ScrollBarType := SB_VERT; MessageType := WM_VSCROLL; ScrollBarCommoand := SB_LINEUP; end; stVDown: begin DeltaY := StepSize; ScrollBarType := SB_VERT; MessageType := WM_VSCROLL; ScrollBarCommoand := SB_LINEDOWN; end; stHLeft: begin DeltaX := StepSize * -1; ScrollBarType := SB_HORZ; MessageType := WM_HSCROLL; ScrollBarCommoand := SB_LINELEFT; end; stHRight: begin DeltaX := StepSize; ScrollBarType := SB_HORZ; MessageType := WM_HSCROLL; ScrollBarCommoand := SB_LINERIGHT; end; end; if (ScrollBarType <> -1) and (MessageType <> -1) and (ScrollBarCommoand <> -1) then begin CanScroll := true; //** Если левая клавиша отпущена (Проверить старший бит на 1) if (GetKeyState(VK_LBUTTON) and $8000) <> $8000 then CanScroll := false; //*** Определить, есть ли еще куда скролить GetScrollRange(GTreeViewToScrollOnDrag.Handle, ScrollBarType, MinRange, MaxRange); Pos := GetScrollPos(GTreeViewToScrollOnDrag.Handle, ScrollBarType); if ((Pos = MinRange) and (GTreeViewScrollType in [stVUp, stHLeft])) or ((Pos = MaxRange) and (GTreeViewScrollType in [stVDown, stHRight])) then CanScroll := false; if Not CanScroll then KillTimer(GHandleWindowForTreeViewScroll, TimerIDTreeViewScrolling) else begin GTreeViewToScrollOnDrag.Perform(MessageType, MakeWParam(ScrollBarCommoand, 0) ,0); CurrTickCount := GetTickCount; if Abs(CurrTickCount - GTreeViewLastRepaintTime) > 100 then begin GTreeViewLastRepaintTime := CurrTickCount; GTreeViewToScrollOnDrag.Repaint; end; end; end; //if (DeltaX <> 0) or (DeltaY <> 0) then //begin // GTreeViewToScrollOnDrag.ScrollBy(DeltaX, DeltaY); // GTreeViewToScrollOnDrag.Refresh; //end; end; end; function AddNodeToTreeViewFly(ATreeView: TFlyTreeViewPro; AParentNode: TFlyNode; const ACaption: String; AImageIndex, AStateIndex: Integer; AData: Pointer): TFlyNode; begin Result := nil; if AParentNode = nil then Result := ATreeView.Items.Add(nil, ACaption) else Result := ATreeView.Items.AddChild(AParentNode, ACaption); if Result <> nil then begin Result.ImageIndex := AImageIndex; Result.SelectedIndex := AImageIndex; Result.StateIndex := AStateIndex; Result.Data := AData; end; end; function CheckNodeHaveParent(aNode, aParent: TTreeNode): Boolean; var Node: TTreeNode; begin Result := false; Node := aNode; while (Node <> nil) do begin Node := Node.Parent; if Node = aParent then begin Result := true; Break; //// BREAK //// end; end; end; function CheckNodesSameParentFly(ANodes: TList): Boolean; var i: integer; FirstNodeParent: TFlyNode; begin Result := false; if ANodes.Count > 0 then begin Result := true; FirstNodeParent := TFlyNode(ANodes[0]).Parent; for i := 0 to ANodes.Count - 1 do if TFlyNode(ANodes[i]).Parent <> FirstNodeParent then begin Result := false; Break; //// BREAK //// end; end; end; function CheckSelectedNodesHaveSameParentFly(ATreeView: TFlyTreeViewPro): Boolean; var SelectedNodes: TList; begin Result := false; SelectedNodes := TList.Create; ATreeView.FillSelectedList(SelectedNodes); Result := CheckNodesSameParentFly(SelectedNodes); FreeAndNil(SelectedNodes); end; procedure ClearTreeView(ATreeView: TTreeView; AFreeNodeData: Boolean = true; ALockEvents: Boolean = false); var i: integer; SavedOnChange: TTVChangedEvent; begin SavedOnChange := nil; if ALockEvents then begin SavedOnChange := ATreeView.OnChange; ATreeView.OnChange := nil; end; try if AFreeNodeData then for i := 0 to ATreeView.Items.Count - 1 do begin FreeMem(ATreeView.Items[i].Data); ATreeView.Items[i].Data := nil; end; ATreeView.Items.Clear; finally if ALockEvents then ATreeView.OnChange := SavedOnChange; end; end; procedure ClearTreeViewFly(ATreeView: TCustomRapidTree; AFreeNodeData: Boolean = true; ALockEvents: Boolean = false; ADataIsObject: Boolean = false); var //i: integer; SavedOnChange: TFTVChangedEvent; SavedOnSelectedChanged: TTreeSelChangedEvent; Node: TFlyNode; begin SavedOnChange := nil; if ATreeView <> nil then begin if ALockEvents then begin SavedOnChange := ATreeView.OnChange; ATreeView.OnChange := nil; if ATreeView is TFlyTreeViewPro then begin SavedOnSelectedChanged := TFlyTreeViewPro(ATreeView).OnSelectedChanged; TFlyTreeViewPro(ATreeView).OnSelectedChanged := nil; end; end; try if AFreeNodeData then begin Node := GetFirstNodeFromFlyTree(ATreeView); //for i := 0 to ATreeView.Items.Count - 1 do while Node <> nil do begin if Node.Data <> nil then begin if ADataIsObject then TObject(Node.Data).Free else FreeMem(Node.Data); Node.Data := nil; end; Node := Node.GetNext; end; end; if ATreeView.Items.Count > 0 then ATreeView.Items.Clear; finally if ALockEvents then begin ATreeView.OnChange := SavedOnChange; if ATreeView is TFlyTreeViewPro then TFlyTreeViewPro(ATreeView).OnSelectedChanged := SavedOnSelectedChanged; end; end; end; end; procedure CopyChildNodesFromList(ATreeView: TTreeView; AParentNode: TTreeNode; ASrcNodes: TObjectList); var SrcNode: TTreeNode; NewNode: TTreeNode; ptrNewDat: PObjectData; i: Integer; begin for i := 0 to ASrcNodes.Count - 1 do begin SrcNode := TTreeNode(ASrcNodes[i]); NewNode := ATreeView.Items.AddChild(AParentNode, SrcNode.Text); NewNode.ImageIndex := SrcNode.ImageIndex; NewNode.SelectedIndex := SrcNode.SelectedIndex; NewNode.StateIndex := SrcNode.StateIndex; NewData(ptrNewDat, ttComponents); ptrNewDat^ := PObjectData(SrcNode.Data)^; NewNode.Data := ptrNewDat; end; end; // ##### Очищает выделенную под ветвь память, и удаляет эту ветвь ##### procedure DeleteNode(ANode: TTreeNode); var ParentNode: TTreeNode; procedure DelNodeData(ADelNode: TTreeNode); var CurrNode: TTreeNode; begin if ADelNode = nil then Exit; //// EXIT //// CurrNode := ADelNode.getFirstChild; while CurrNode <> nil do begin DelNodeData(CurrNode); CurrNode := CurrNode.getNextSibling; end; FreeMem(ADelNode.Data); ADelNode.Data := nil; end; begin try try DelNodeData(ANode); ParentNode := ANode.Parent; //*** Если удаляется предпоследний ноуд, свернуть парент, а то сам не может if (ParentNode <> nil) and (ParentNode.Count = 1) then begin ParentNode.Expanded := false; ParentNode.HasChildren := false; end; ANode.Delete; ANode := nil; except on E: Exception do AddExceptionToLog('DeleteNode: '+E.Message); end; finally end; end; procedure DeleteChildNodes(ANode: TTreeNode); var ChildNode: TTreeNode; PrevNode: TTreeNode; TreeView: TTreeView; ChangedEvent: TTVChangedEvent; begin if Assigned(ANode) then begin TreeView := TTreeView(ANode.TreeView); ChangedEvent := nil; if Assigned(TreeView) then begin ChangedEvent := TreeView.OnChange; TreeView.OnChange := nil; end; try ChildNode := ANode.GetFirstChild; PrevNode := nil; while ChildNode <> nil do begin PrevNode := ChildNode; ChildNode := ChildNode.getNextSibling; DeleteNode(PrevNode); end; finally if Assigned(TreeView) then TreeView.OnChange := ChangedEvent; end; end; end; procedure ExchangeSiblingNodes(ANode1, ANode2: TTreeNode); var NextNode: TTreeNode; PrevNode: TTreeNode; begin if ANode1.Parent = ANode2.Parent then begin PrevNode := ANode2.getPrevSibling; NextNode := ANode2.getNextSibling; ANode2.MoveTo(ANode1, naInsert); if NextNode <> nil then ANode1.MoveTo(NextNode, naInsert) else begin ANode1.MoveTo(PrevNode, naInsert); PrevNode.MoveTo(ANode1, naInsert); end; end; end; procedure ExchangeSiblingNodesFly(ANode1, ANode2: TFlyNode); var NextNode: TFlyNode; PrevNode: TFlyNode; begin if ANode1.Parent = ANode2.Parent then begin PrevNode := ANode2.getPrevSibling; NextNode := ANode2.getNextSibling; ANode2.MoveTo(ANode1, naInsert); if NextNode <> nil then ANode1.MoveTo(NextNode, naInsert) else begin ANode1.MoveTo(PrevNode, naInsert); PrevNode.MoveTo(ANode1, naInsert); end; end; end; function GetAllChildNodes(ANode: TTreeNode; aSelected: Integer=biNone): TObjectList; //var //NextSiblingNode: TTreeNode; //CurrNode: TTreeNode; procedure StepGetAllChildNodes(ACurrNode: TTreeNode); var CurrNode: TTreeNode; begin CurrNode := ACurrNode.getFirstChild; while CurrNode <> nil do begin Result.Add(CurrNode); StepGetAllChildNodes(CurrNode); CurrNode := CurrNode.GetNextSibling; end; end; begin Result := TObjectList.Create(false); StepGetAllChildNodes(ANode); //NextSiblingNode := ANode.getNextSibling; // CurrNode := ANode.getFirstChild; // while (CurrNode <> nil) and (CurrNode <> NextSiblingNode) do // begin // Result.Add(CurrNode); // CurrNode := CurrNode.GetNext; // end; end; procedure ExchangeTreesNodesFly(ATreeView1, ATreeView2: TFlyTreeViewPro; AOnAfterSetNodeData: TNotifyEvent); var TempNodes: TFlyNodes; SavedOnChange1: TFTVChangedEvent; SavedOnChange2: TFTVChangedEvent; SavedOnSelectedChanged1: TTreeSelChangedEvent; SavedOnSelectedChanged2: TTreeSelChangedEvent; NodeDataFromTree1: TRapList; NodeDataFromTree2: TRapList; function SendTreeNodeDataToList(ATreeView: TFlyTreeViewPro): TRapList; var Node: TFlyNode; begin Result := TRapList.Create; Node := GetFirstNodeFromFlyTree(ATreeView); while Node <> nil do begin Result.Add(Node.Data); Node := Node.GetNext; end; end; procedure SendDataFromListToTree(ATreeView: TFlyTreeViewPro; AList: TRapList); var Node: TFlyNode; i: Integer; begin Node := GetFirstNodeFromFlyTree(ATreeView); i := 0; while Node <> nil do begin Node.Data := AList[i]; if Assigned(AOnAfterSetNodeData) then AOnAfterSetNodeData(Node); Node := Node.GetNext; i := i + 1; end; end; begin try TempNodes := TFlyNodes.Create(nil); try SavedOnChange1 := ATreeView1.OnChange; SavedOnChange2 := ATreeView2.OnChange; SavedOnSelectedChanged1 := ATreeView1.OnSelectedChanged; SavedOnSelectedChanged2 := ATreeView2.OnSelectedChanged; ATreeView1.OnChange := nil; ATreeView2.OnChange := nil; ATreeView1.OnSelectedChanged := nil; ATreeView2.OnSelectedChanged := nil; try ATreeView1.Items.BeginUpdate; ATreeView2.Items.BeginUpdate; try NodeDataFromTree1 := SendTreeNodeDataToList(ATreeView1); NodeDataFromTree2 := SendTreeNodeDataToList(ATreeView2); TempNodes.Assign(ATreeView1.Items); ATreeView1.Items.Assign(ATreeView2.Items); ATreeView2.Items.Assign(TempNodes); SendDataFromListToTree(ATreeView1, NodeDataFromTree2); SendDataFromListToTree(ATreeView2, NodeDataFromTree1); FreeAndNil(NodeDataFromTree1); FreeAndNil(NodeDataFromTree2); finally ATreeView1.Items.EndUpdate; ATreeView2.Items.EndUpdate; end; finally ATreeView1.OnChange := SavedOnChange1; ATreeView2.OnChange := SavedOnChange2; ATreeView1.OnSelectedChanged := SavedOnSelectedChanged1; ATreeView2.OnSelectedChanged := SavedOnSelectedChanged2; end; finally TempNodes.Free; end; except on E: Exception do AddExceptionToLogEx('ExchangeTreesNodesFly', E.Message); end; end; function GetAllChildNodesFly(ANode: TFlyNode): TObjectList; //var //NextSiblingNode: TFlyNode; //CurrNode: TFlyNode; procedure StepGetAllChildNodes(ACurrNode: TFlyNode); var CurrNode: TFlyNode; begin CurrNode := ACurrNode.getFirstChild; while CurrNode <> nil do begin Result.Add(CurrNode); StepGetAllChildNodes(CurrNode); CurrNode := CurrNode.GetNextSibling; end; end; begin Result := TObjectList.Create(false); StepGetAllChildNodes(ANode); //NextSiblingNode := ANode.getNextSibling; // CurrNode := ANode.getFirstChild; // while (CurrNode <> nil) and (CurrNode <> NextSiblingNode) do // begin // Result.Add(CurrNode); // CurrNode := CurrNode.GetNext; // end; end; function GetComponKindByItemType(AItemType: Integer): TComponKind; begin Result := ckNone; if IsCatalogItemTypeForCompon(AItemType) then Result := ckCompon else if IsComponItemType(AItemType) then Result := ckCompl; end; function GetFirstNodeFromFlyTree(AFlyTreeView: TCustomRapidTree): TFlyNode; begin Result := nil; if AFlyTreeView.Items.Count > 0 then Result := AFlyTreeView.Items[0]; end; function GetTreeViewDataListFly(ATreeView: TFlyTreeViewPro): TList; var Node: TFlyNode; begin Result := TList.Create; if ATreeView.Items.Count > 0 then begin Node := ATreeView.Items[0]; while Node <> nil do begin Result.Add(Node.Data); Node := Node.GetNext; end; end; end; function GetTreeViewNodeByData(ATreeView: TTreeView; AData: Pointer; ASelectFinded: Boolean): TTreeNode; var i: Integer; CurrNode: TTreeNode; begin Result := nil; for i := 0 to ATreeView.Items.Count - 1 do begin CurrNode := ATreeView.Items[i]; if CurrNode.Data = AData then begin Result := CurrNode; if ASelectFinded then ATreeView.Selected := CurrNode; Break; ///// BREAK ///// end; end; end; function GetTreeViewNodeByDataFly(ATreeView: TFlyTreeViewPro; AData: Pointer; ASelectFinded: Boolean): TFlyNode; var i: Integer; CurrNode: TFlyNode; begin Result := nil; CurrNode := GetFirstNodeFromFlyTree(ATreeView); //for i := 0 to ATreeView.Items.Count - 1 do while CurrNode <> nil do begin //CurrNode := ATreeView.Items[i]; if CurrNode.Data = AData then begin Result := CurrNode; if ASelectFinded then ATreeView.Selected := CurrNode; Break; ///// BREAK ///// end; CurrNode := CurrNode.GetNext; end; end; function GetTreeViewNodeByPathFly(ATreeView: TFlyTreeViewPro; const APath, ASeparator: String): TFlyNode; var Strings: TStringList; Node: TFlyNode; i: integer; s: string; begin Result := nil; if (ATreeView = nil) or (ATreeView.Items.Count = 0) or (APath = '') or (ASeparator = '') then Exit; ///// EXIT ///// Strings := TStringList.Create; // Меняем сепаратор на первод строки s := ''; if ASeparator <> #13#10 then s := StringReplace(APath, ASeparator, #13#10,[rfReplaceAll]); // Получаем список уровней Strings.Text := s; // Начинаем с нулевой ноды дерева Node := ATreeView.Items[0]; // Проходим по всему списку уровней пути for i := 0 to Strings.Count - 1 do begin // Ищем имя ноды на текущем уровне while (Node <> nil) and (Node.Text <> Strings[i]) do Node := Node.getNextSibling; // Нода не найдена if Node = nil then break; // Переходим на уровень ниже if i < Strings.Count - 1 then Node := Node.getFirstChild; end; Strings.Free; Result := Node; end; function GetTreeViewNodePathFly(ANode: TFlyNode; const ASeparator: String): String; begin Result := ''; while ANode <> nil do begin if Result <> '' then Result := ASeparator + Result; Result := ANode.Text + Result; ANode := ANode.Parent; end; end; function GetTreeViewNodesFly(ATree: TCustomRapidTree): TList; var Node: TFlyNode; begin Result := TList.Create; Node := ATree.GetFirstVisibleNode; while Node <> nil do begin Result.Add(Node); Node := Node.GetNext; end; end; function GetTreeViewFirstSiblingNode(ANode: TTreeNode): TTreeNode; var CurrNode: TTreeNode; PrevNode: TTreeNode; begin Result := nil; CurrNode := ANode; while CurrNode <> nil do begin PrevNode := CurrNode; CurrNode := CurrNode.getPrevSibling; if CurrNode = nil then Result := PrevNode; end; end; function GetTreeViewFirstSiblingNodeFly(ANode: TFlyNode): TFlyNode; var CurrNode: TFlyNode; PrevNode: TFlyNode; begin Result := nil; CurrNode := ANode; while CurrNode <> nil do begin PrevNode := CurrNode; CurrNode := CurrNode.getPrevSibling; if CurrNode = nil then Result := PrevNode; end; end; function GetTreeViewFirstTopNode(ANode: TTreeNode): TTreeNode; var TopFirstNode: TTreeNode; PrevSiblingNode: TTreeNode; begin Result := nil; if Assigned(ANode) then begin TopFirstNode := ANode; while TopFirstNode.Parent <> nil do TopFirstNode := TopFirstNode.Parent; PrevSiblingNode := TopFirstNode.getPrevSibling; while PrevSiblingNode <> nil do begin TopFirstNode := PrevSiblingNode; PrevSiblingNode := TopFirstNode.getPrevSibling; end; Result := TopFirstNode; end; end; function GetTreeViewFirstTopNodeFly(ANode: TFlyNode): TFlyNode; var TopFirstNode: TFlyNode; PrevSiblingNode: TFlyNode; begin Result := nil; if Assigned(ANode) then begin TopFirstNode := ANode; while TopFirstNode.Parent <> nil do TopFirstNode := TopFirstNode.Parent; PrevSiblingNode := TopFirstNode.getPrevSibling; while PrevSiblingNode <> nil do begin TopFirstNode := PrevSiblingNode; PrevSiblingNode := TopFirstNode.getPrevSibling; end; Result := TopFirstNode; end; end; function GetTreeViewSelectedNodeInComboOnClose(ATreeView: TFlyTreeViewPro; ADropDown: TISDropDown): TFlyNode; var ActualColumn: Integer; NodeIndex: Integer; begin Result := nil; ActualColumn := ATreeView.Columns.VisibleColumn[ATreeView.Col].Index; //*** Определить выбранную ветвь из комбаря if TPopupTree(ADropDown.ContainedControl).Selected <> nil then begin NodeIndex := TPopupTree(ADropDown.ContainedControl).Selected.Index; if (NodeIndex <> -1) and (NodeIndex <= ATreeView.Columns[ActualColumn].EditorStyle.Sections[0].Items.Count - 1) then Result := ATreeView.Columns[ActualColumn].EditorStyle.Sections[0].Items[NodeIndex]; end; end; function GetTreeViewSelectedNodesFly(ATreeView: TFlyTreeViewPro): TList; var SelectedNode: TFlyNode; begin Result := TList.Create; SelectedNode := ATreeView.Items.GetFirstSelectedNode; while SelectedNode <> nil do begin Result.Add(SelectedNode); SelectedNode := ATreeView.Items.GetNextSelectedNode(SelectedNode); end; end; function GetTreeViewSelectedNodesCountFly(ATreeView: TFlyTreeViewPro): Integer; var SelectedNodes: TList; begin Result := 0; SelectedNodes := TList.Create; ATreeView.FillSelectedList(SelectedNodes); Result := SelectedNodes.Count; FreeAndNil(SelectedNodes); end; function IsGraphModTemplate(ATemplateType: Integer): Boolean; begin Result := ATemplateType in [tgtArh, tgtRoof]; end; function IsCatalogItemType(AItemType: Integer): Boolean; begin Result := false; case AItemType of itDir, itProjMan, itProject, itList, itRoom, itSCSConnector, itSCSLine, itArhContainer: Result := true; end; end; function IsCatalogItemTypeForCompon(AItemType: Integer): Boolean; begin Result := false; case AItemType of itSCSLine, itSCSConnector, itArhContainer: Result := true; itDir: begin //if ADBKind = bkNormBase then Result := true; end; end; end; function IsComponItemType(AItemType: Integer): Boolean; begin Result := false; //if (AItemType = itComponCon) or (AItemType = itComponLine) or // (AItemType = itLinkCompLine) or (AItemType = itLinkCompCon) then case AItemType of itComponCon, itComponLine, itLinkCompLine, itLinkCompCon: Result := true; else begin if IsArchComponByItemType(AItemType) then Result := true; end; end; end; function IsTemplateImageIndex(AItemType: Integer): Boolean; begin Result := false; if (AItemType = tciiTemplateCon) or (AItemType = tciiTemplateLine) then Result := true; end; function IsComponentNode(ANode: TTreeNode): Boolean; //var // ItemType: Integer; begin Result := false; if Assigned(ANode) then Result := IsComponItemType(PObjectData(ANode.Data).ItemType); //begin // ItemType := PObjectData(ANode.Data).ItemType; // if (ItemType = itComponCon) or (ItemType = itComponLine) or // (ItemType = itLinkCompLine) or (ItemType = itLinkCompCon) then // Result := true; //end; end; function IsHiddenNodeByParantFly(ANode: TFlyNode): Boolean; var ParentNode: TFlyNode; begin Result := false; ParentNode := ANode; while ParentNode <> nil do begin if ParentNode.Hidden then begin Result := true; Break; //// BREAK //// end; ParentNode := ParentNode.Parent; end; end; function IsGroupObjectNode(ANode: TTreeNode): Boolean; //var // ItemType: Integer; begin Result := false; if Assigned(ANode) then begin //ItemType := PObjectData(ANode.Data).ItemType; //if (ItemType = itSCSLineGroup) or // (ItemType = itSCSConnGroup) or // (ItemType = itSCSEmptyGroup) then // Result := true; Result := IsSCSGroupItemType(PObjectData(ANode.Data).ItemType); end; end; function IsImageIndexShowConnectCompon(AImageIndex: Integer): Boolean; begin Result := (AImageIndex = tciiConnectedComponLineFill) or (AImageIndex = tciiConnectedComponLinePartFill) or (AImageIndex = tciiConnectedComponConFill) or (AImageIndex = tciiConnectedComponConPartFill); end; function IsSCSGroupItemType(AItemType: Integer): Boolean; begin Result := false; if (AItemType = itSCSLineGroup) or (AItemType = itSCSConnGroup) or (AItemType = itSCSEmptyGroup) then Result := true; end; function IsSCSObjectItemType(AItemType: Integer): Boolean; begin Result := (AItemType = itSCSLine) or (AItemType = itSCSConnector); end; procedure ReloadTreeView(ATreeView: TTreeView); //var i: integer; begin if Assigned(ATreeView) then begin TF_Main(ATreeView.Owner).LockTreeAndGrid(true); try //for i := 0 to ATreeView.Items.Count - 1 do // FreeMem(ATreeView.Items[i].Data); //ATreeView.Items.Clear; ClearTreeView(ATreeView); if ATreeView.Owner is TForm then TF_Main(ATreeView.Owner).AddNodes(nil); finally TF_Main(ATreeView.Owner).LockTreeAndGrid(false); end; end; end; function ReplaceTextInStr(const ASrch, AReplace, AText: String; AWholeWord: Boolean; AWasReplace: PBoolean): String; var BeginIndex: Integer; CurrSrchIndex: Integer; EndIndex: Integer; BeforeBeginCh: Char; AfterEndCh: Char; i: Integer; Ch: Char; Len: Integer; LenSrch: Integer; LenReplace: Integer; TextSymbUp: String; FindedCh: Boolean; begin Result := AText; try if AWasReplace <> nil then AWasReplace^ := false; if ASrch <> '' then begin //NoTextSymb := '.,'' ";:~!?№@#$%^&*()[]-*+=\/|<>'; TextSymbUP := cnstAbsUP + cnstAbsCyrUP; LenSrch := Length(ASrch); LenReplace := Length(AReplace); BeforeBeginCh := #0; AfterEndCh := #0; CurrSrchIndex := 1; Len := Length(AText); i := 1; while i <= Len do begin Ch := Result[i]; FindedCh := false; if Ch = ASrch[CurrSrchIndex] then begin FindedCh := true; // Если найден первый символ строки поиска if CurrSrchIndex = 1 then begin BeginIndex := i; if i > 1 then begin BeforeBeginCh := AnsiUpperCase(Result[i-1])[1]; //CharUpperBuff(Pointer(BeforeBeginCh), 1); end else BeforeBeginCh := #0; // Если нужно искать слово целиком if AWholeWord then if Pos(BeforeBeginCh, TextSymbUP) > 0 then FindedCh := false; end; // Если найден последний символ строки поиска if CurrSrchIndex = LenSrch then begin EndIndex := i; if i < Len then begin AfterEndCh := AnsiUpperCase(Result[i+1])[1]; //CharUpperBuff(Pointer(AfterEndCh), 1); end else if i = Len then AfterEndCh := #0; // Если нужно искать слово целиком if AWholeWord then if Pos(AfterEndCh, TextSymbUP) > 0 then FindedCh := false; // Делаем замену if FindedCh then begin Delete(Result, BeginIndex, EndIndex-BeginIndex+1); Insert(AReplace, Result, BeginIndex); Len := Len - LenSrch + LenReplace; i := BeginIndex + LenReplace; // Уменьшаем на 1, потому что ниже будет инкремент на 1 i := i - 1; FindedCh := false; if AWasReplace <> nil then AWasReplace^ := true; end; end; if FindedCh then Inc(CurrSrchIndex); end; if Not FindedCh then if CurrSrchIndex > 1 then CurrSrchIndex := 1; i := i + 1; end; end; except on E: Exception do AddExceptionToLogEx('ReplaceTextInStr', E.Message); end; end; procedure ReplaceTextInStringList(ASrch, AReplace: String; AStringList: TStringList; AWholeWord: Boolean); var i: Integer; StrToReplace: String; WasReplaced: Boolean; begin if ASrch <> '' then begin for i := 0 to AStringList.Count - 1 do begin StrToReplace := AStringList[i]; StrToReplace := ReplaceTextInStr(ASrch, AReplace, StrToReplace, true, @WasReplaced); if WasReplaced then AStringList[i] := StrToReplace; end; end; end; procedure SelectTreeViewNodesFly(ATreeView: TFlyTreeViewPro; ANodesToSelect: TList; ASelected: Boolean); var i: Integer; begin for i := 0 to ANodesToSelect.Count - 1 do TFlyNode(ANodesToSelect[i]).Selected := ASelected; ATreeView.Repaint; end; procedure SortComplexStringList(AMainStringList, ASecondStringList: TStringList); var i: Integer; IDGUIDObject: TIDGuidObject; begin for i := 0 to AMainStringList.Count - 1 do begin IDGUIDObject := TIDGuidObject.Create; IDGUIDObject.GUID := ASecondStringList[i]; // запомнем текущий объект строки IDGUIDObject.ID := Integer(AMainStringList.Objects[i]); AMainStringList.Objects[i] := IDGUIDObject; end; AMainStringList.Sort; ASecondStringList.Clear; for i := 0 to AMainStringList.Count - 1 do begin IDGUIDObject := TIDGuidObject(AMainStringList.Objects[i]); ASecondStringList.Add(IDGUIDObject.GUID); AMainStringList.Objects[i] := TObject(IDGUIDObject.ID); FreeAndNil(IDGUIDObject); end; end; procedure SortStrings(AStrings: TStrings); var i, j: Integer; CurrStrI: String; CurrStrJ: String; TmpStr: String; TmpObject: TObject; begin for i := 0 to AStrings.Count - 1 do begin CurrStrI := AStrings.Strings[i]; for j := i to AStrings.Count - 1 do begin CurrStrJ := AStrings.Strings[j]; if CurrStrI > CurrStrJ then begin TmpStr := CurrStrI; CurrStrI := CurrStrJ; CurrStrJ := TmpStr; AStrings.Strings[i] := CurrStrI; AStrings.Strings[j] := CurrStrJ; TmpObject := AStrings.Objects[i]; AStrings.Objects[i] := AStrings.Objects[j]; AStrings.Objects[j] := TmpObject; end; end; end; end; procedure SortTreeViewChildNodes(AParentNode: TTreeNode; ATreeView: TTreeView; ASortType: TTreeSortType; AReverse: Boolean = false); var ChildNodes: TObjectList; Node: TTreeNode; NodeI: TTreeNode; NodeJ: TTreeNode; i, j: Integer; CanReplace: Boolean; begin ATreeView.Items.BeginUpdate; try ChildNodes := TObjectList.Create(false); if AParentNode <> nil then begin if ASortType = tstSortID then begin Node := AParentNode.getFirstChild; while Node <> nil do begin ChildNodes.Add(Node); Node := Node.getNextSibling; end; end else if ASortType = tstText then AParentNode.AlphaSort; end else if ATreeView.Items.Count > 0 then begin Node := GetTreeViewFirstTopNode(ATreeView.Items[0]); if Node <> nil then while Node <> nil do begin ChildNodes.Add(Node); Node := Node.getNextSibling; end; end; for i := 0 to ChildNodes.Count - 1 do begin NodeI := TTreeNode(ChildNodes[i]); for j := i to ChildNodes.Count - 1 do begin NodeJ := TTreeNode(ChildNodes[j]); CanReplace := false; case ASortType of tstText: if Not AReverse then begin if NodeI.Text > NodeJ.Text then CanReplace := true; end else if NodeI.Text < NodeJ.Text then CanReplace := true; tstSortID: begin if (TObject(NodeI.Data) is TBasicSCSClass) and (TObject(NodeJ.Data) is TBasicSCSClass) then begin if Not AReverse then begin if TBasicSCSClass(NodeI.Data).SortID > TBasicSCSClass(NodeJ.Data).SortID then CanReplace := true; end else if TBasicSCSClass(NodeI.Data).SortID < TBasicSCSClass(NodeJ.Data).SortID then CanReplace := true; end; end; end; if CanReplace then begin ExchangeSiblingNodes(NodeI, NodeJ); ExchangeObjects(NodeI, NodeJ); ChildNodes[i] := NodeI; ChildNodes[j] := NodeJ; end; end; end; FreeAndNil(ChildNodes); finally ATreeView.Items.EndUpdate; end; end; function CompareTreeViewNodesFlyText(Item1, Item2: TTreeCollection): Integer; stdcall; begin Result := CompareStr(item1.Caption, Item2.Caption); end; function CompareTreeViewNodesFlyTextReverse(Item1, Item2: TTreeCollection): Integer; stdcall; begin Result := CompareStr(item2.Caption, Item1.Caption); end; function CompareTreeViewNodesFlySortID(Item1, Item2: TTreeCollection): Integer; stdcall; begin Result := CompareInt(TBasicSCSClass(Item1.Data).SortID, TBasicSCSClass(Item2.Data).SortID); end; function CompareTreeViewNodesFlySortIDReverse(Item1, Item2: TTreeCollection): Integer; stdcall; begin Result := CompareInt(TBasicSCSClass(Item2.Data).SortID, TBasicSCSClass(Item1.Data).SortID); end; procedure SortTreeViewChildNodesFly(AParentNode: TFlyNode; ATreeView: TFlyTreeViewPro; ASortType: TTreeSortType; AReverse: Boolean = false); var Node: TFlyNode; TreeColl: TTreeCollection; begin ATreeView.Items.BeginUpdate; try TreeColl := AParentNode; if TreeColl = nil then if ATreeView.Items.Count > 0 then TreeColl := ATreeView.Items; //Node := GetTreeViewFirstTopNodeFly(ATreeView.Items[0]); if TreeColl <> nil then begin if ASortType = tstText then begin if AReverse then TreeColl.CustomSort(CompareTreeViewNodesFlyTextReverse, false) else TreeColl.CustomSort(CompareTreeViewNodesFlyText, false) end else if ASortType = tstSortID then begin if AReverse then TreeColl.CustomSort(CompareTreeViewNodesFlySortIDReverse, false) else TreeColl.CustomSort(CompareTreeViewNodesFlySortID, false); end; end; finally ATreeView.Items.EndUpdate; end; end; procedure SortTreeViewChildNodesFlyOld(AParentNode: TFlyNode; ATreeView: TFlyTreeViewPro; ASortType: TTreeSortType; AReverse: Boolean = false); var ChildNodes: TObjectList; Node: TFlyNode; NodeI: TFlyNode; NodeJ: TFlyNode; i, j: Integer; CanReplace: Boolean; begin ATreeView.Items.BeginUpdate; try ChildNodes := TObjectList.Create(false); if AParentNode <> nil then begin if ASortType = tstSortID then begin Node := AParentNode.getFirstChild; while Node <> nil do begin ChildNodes.Add(Node); Node := Node.getNextSibling; end; end else if ASortType = tstText then AParentNode.AlphaSort; end else if ATreeView.Items.Count > 0 then begin Node := GetTreeViewFirstTopNodeFly(ATreeView.Items[0]); if Node <> nil then while Node <> nil do begin ChildNodes.Add(Node); Node := Node.getNextSibling; end; end; for i := 0 to ChildNodes.Count - 1 do begin NodeI := TFlyNode(ChildNodes[i]); for j := i to ChildNodes.Count - 1 do begin NodeJ := TFlyNode(ChildNodes[j]); CanReplace := false; case ASortType of tstText: if Not AReverse then begin if NodeI.Text > NodeJ.Text then CanReplace := true; end else if NodeI.Text < NodeJ.Text then CanReplace := true; tstSortID: begin if (TObject(NodeI.Data) is TBasicSCSClass) and (TObject(NodeJ.Data) is TBasicSCSClass) then begin if Not AReverse then begin if TBasicSCSClass(NodeI.Data).SortID > TBasicSCSClass(NodeJ.Data).SortID then CanReplace := true; end else if TBasicSCSClass(NodeI.Data).SortID < TBasicSCSClass(NodeJ.Data).SortID then CanReplace := true; end; end; end; if CanReplace then begin ExchangeSiblingNodesFly(NodeI, NodeJ); ExchangeObjects(NodeI, NodeJ); ChildNodes[i] := NodeI; ChildNodes[j] := NodeJ; end; end; end; FreeAndNil(ChildNodes); finally ATreeView.Items.EndUpdate; end; end; procedure CheckUnCheckListViewItems(AListView: TListView; ACheck: Boolean); var i: Integer; begin for i := 0 to AListView.Items.Count - 1 do AListView.Items[i].Checked := ACheck; end; // ##### Очищает Список поиска ##### procedure ClearListView(AListView: TListView); var i: Integer; begin for i := 0 to AListView.Items.Count - 1 do if AListView.Items[i].Data <> nil then FreeMem(AListView.Items[i].Data); AListView.Items.Clear; end; procedure ClearListViewRz(AListView: TRzListView); var i: Integer; begin for i := 0 to AListView.Items.Count - 1 do if AListView.Items[i].Data <> nil then FreeMem(AListView.Items[i].Data); AListView.Items.Clear; end; procedure ClearListViewObjects(AListItems: TListItems); var i: Integer; begin for i := 0 to AListItems.Count - 1 do if AListItems[i].Data <> nil then begin TObject(AListItems[i].Data).Free; AListItems[i].Data := nil; end; AListItems.Clear; end; // ##### Строит и разворачивает дерево ##### { procedure BuildTree(AForm: TForm; ATreeType: TTreeType); procedure Step(AParentNode: TTreeNode) begin end; begin try finally end; end; } procedure BuildTree(AForm: TForm; ATreeType: TTreeType); var TopNode: TTreeNode; i: Integer; ID_Catalog: Integer; IDCatalogList: TIntList; FolderCount: Integer; DirCnt: Integer; Node: TTreeNode; TableName: String; begin Node := nil; case ATreeType of ttComponents: TableName := tnCatalog; ttGuide : TableName := tnDirectoryType; end; with TF_Main(AForm) do begin //*** Создать список ID-в всех папок SetSQLToQuery(DM.scsQSelect, ' SELECT ID FROM '+ TableName +' ORDER BY Parent_ID '); IDCatalogList := TIntList.Create; DM.IntFieldToIntList(IDCatalogList, DM.scsQSelect, fnID); //*** Включить анимацию F_Animate.GMaxProgressPos := IDCatalogList.Count; F_Animate.StartAnimate(cBaseCommon23, aviFindFolder, aiProgressBar); //*** Раскрыть все папки FolderCount := IDCatalogList.Count; for i := 0 to FolderCount - 1 do begin ID_Catalog := IDCatalogList[i]; case ATreeType of ttComponents: begin Node := FindTreeNodeByDat(ID_Catalog, [itDir]); if Node = nil then Node := FindComponOrDirInTree(ID_Catalog, false); end; ttGuide: begin Node := F_CaseForm.GetNodeFromTreeByID(ID_Catalog); if Node = nil then Node := F_CaseForm.FindNodeByID(ID_Catalog); end; end; if Node <> nil then Node.Expanded := true; F_Animate.SetProgressPos(i+1); F_Animate.Update; end; IDCatalogList.Free; F_Animate.Close; end; end; // ##### Разворачивание всех папок дерева ##### procedure ExpandTree(AForm: TForm; ATreeType: TTreeType); var TreeView: TTreeView; begin try with TF_Main(AForm) do begin TreeView := nil; case ATreeType of ttComponents : TreeView := Tree_Catalog; ttGuide : TreeView := F_CaseForm.Tree_InterfType; end; if Assigned(TreeView) then begin TreeView.Items.BeginUpdate; try BuildTree(AForm, ATreeType); finally TreeView.Items.EndUpdate; TreeView.Refresh; end; if ATreeType = ttComponents then EnableEditDel(itAuto); end; end; except on E: Exception do AddExceptionToLog('ExpandTree: '+E.Message); end; end; procedure ExpandChildNodes(ANode: TTreeNode); var Node: TTreeNode; begin Node := ANode.getFirstChild; while Node <> nil do begin Node.Expanded := true; Node := Node.getNextSibling; end; end; procedure ExpandChildNodesFly(ANode: TFlyNode); var Node: TFlyNode; begin Node := ANode.getFirstChild; while Node <> nil do begin Node.Expanded := true; Node := Node.getNextSibling; end; end; procedure CollapseNode(ANode: TTreeNode; ARecurse: Boolean); begin if ANode <> nil then begin ProcessMessagesEx; BeginProgress; try ANode.Collapse(true); finally EndProgress; end; end; end; procedure CollapseNodeFly(ANode: TFlyNode; ARecurse: Boolean); begin if ANode <> nil then begin //ProcessMessagesEx; ANode.Collapse(true); end; end; procedure ExpandNode(ANode: TTreeNode; ARecurse: Boolean); procedure StepExpand(AStepNode: TTreeNode); var ChildNode: TTreeNode; begin AStepNode.Expanded := true; ChildNode := AStepNode.getFirstChild; while ChildNode <> nil do begin StepExpand(ChildNode); ChildNode := ChildNode.getNextSibling; end; end; begin if ANode <> nil then begin ProcessMessagesEx; BeginProgress; try ANode.Owner.BeginUpdate; try if ARecurse then StepExpand(ANode) else ANode.Expanded := true; finally ANode.Owner.EndUpdate; end; finally EndProgress; end; end; end; procedure ExpandNodeFly(ANode: TFlyNode; ARecurse: Boolean); procedure StepExpand(AStepNode: TFlyNode); var ChildNode: TFlyNode; begin AStepNode.Expanded := true; ChildNode := AStepNode.getFirstChild; while ChildNode <> nil do begin StepExpand(ChildNode); ChildNode := ChildNode.getNextSibling; end; end; begin if ANode <> nil then begin //ProcessMessagesEx; ANode.Owner.BeginUpdate; try if ARecurse then StepExpand(ANode) else ANode.Expanded := true; finally ANode.Owner.EndUpdate; end; end; end; // ##### Сворачивает все папки в дереве ##### procedure CollapseTree(AForm: TForm; ATreeType: TTreeType); var Node: TTreeNode; Count: Integer; i: Integer; TreeView: TTreeView; begin with (AForm as TF_Main) do begin TreeView := Tree_Catalog; case ATreeType of ttComponents : TreeView := Tree_Catalog; ttGuide : TreeView := F_CaseForm.Tree_InterfType; end; TreeView.Items.BeginUpdate; Node := TreeView.TopItem; Count := TreeView.Items.Count; F_Animate.GMaxProgressPos := Count; F_Animate.StartAnimate(cBaseCommon24, aviFindFolder, aiProgressBar); for i := 0 to Count - 1 do begin TreeView.Items[i].Expanded := false; F_Animate.SetProgressPos(i+1); end; F_Animate.Close; TreeView.Items.EndUpdate; end; end; // ##### Содержится ли папка Node в папке Sub ##### function HaveNodeSub(ANode, ASub: TTreeNode): Boolean; var Node: TTreeNode; Sub: TTreeNode; begin Result := false; Node := ANode; Sub := ASub; if (Node = nil) or (Sub = nil) then Exit; Result := false; while (Sub <> nil) and (Sub <> Node) do Sub := Sub.Parent; if Sub = Node then Result := true; end; function HaveNodeSubByPObjectData(ANode, ASub: TTreeNode): Boolean; var Node: TTreeNode; NodeDat: PObjectData; Sub: TTreeNode; SubDat: PObjectData; begin Result := false; Node := ANode; NodeDat := Node.Data; Sub := ASub; if (Node = nil) or (Sub = nil) then Exit; Result := false; while Sub <> nil do begin SubDat := Sub.Data; if (Sub = Node) or ((SubDat.ObjectID = NodeDat.ObjectID) and (SubDat.ItemType = NodeDat.ItemType)) then begin Result := true; Break; //// BREAK //// end; Sub := Sub.Parent; end; end; procedure ClearTree(ATreeView: TTreeView); var NCount: Integer; i: Integer; begin if ATreeView <> nil then begin NCount := ATreeView.Items.Count; for i := 0 to NCount - 1 do FreeMem(ATreeView.Items[i].Data); ATreeView.Items.Clear; end; end; function IsCanNBComponNodeHaveConnection(ANode: TTreeNode): Boolean; begin Result := false; if ANode <> nil then if PObjectData(ANode.Data).ItemType in [itComponLine, itComponCon] then begin if (PObjectData(ANode.Parent.Data).ItemType = PObjectData(ANode.Data).ItemType) then Result := true; if GIsConnChildToTopCompon then Result := true; end; end; function GetParentNodeByLevelFly(ANode: TFlyNode; ALevel: Integer): TFlyNode; begin Result := ANode; while Result.Level > ALevel do Result := Result.Parent; end; procedure MakeNodeVisible(ANode: TTreeNode); var TreeView: TCustomTreeView; NodeRect: TRect; i: Integer; begin if Not ANode.IsVisible then ANode.MakeVisible; if Not ANode.IsVisible then begin TreeView := ANode.Owner.Owner; i := 1; while i <= TreeView.Height do begin TreeView.ScrollBy(0, -10); //ScrollTreeOnDrag(TTreeView(TreeView), 1, 10, 2); NodeRect := ANode.DisplayRect(false); if NodeRect.Top > 0 then Break; //// BREAK //// if ANode.IsVisible then Break; //// BREAK //// i := i + 10; end; end; end; procedure SelectNodeFly(ATreeView: TFlyTreeViewPro; ANode: TFlyNode); begin if ANode <> nil then begin ATreeView.RefreshNodeList(nil); ATreeView.FixupRows; ATreeView.Selected := ANode; end; end; procedure ShowNode(ATreeView: TTreeView; ANode: TTreeNode); var CurrNode: TTreeNode; PrevNode: TTreeNode; TmpPrevNode: TTreeNode; TmpPrevParentNode: TTreeNode; i: Integer; begin //Exit; //04.04.2012 if Assigned(ATreeView) and Assigned(ANode) then begin // Tolik 05/04/2021 -- ATreeView.Items.BeginUpdate; try // {if Not ANode.IsVisible then begin //MakeNodeVisible(ANode); //ANode.MakeVisible; ANode.MakeVisible; ATreeView.TopItem := ANode; end;} CurrNode := ANode; PrevNode := CurrNode; for i := 1 to Round(ATreeView.Height/30) do if CurrNode <> nil then begin PrevNode := CurrNode; TmpPrevNode := CurrNode.GetPrevVisible; if TmpPrevNode = nil then begin TmpPrevNode := CurrNode.GetPrev; TmpPrevParentNode := nil; if TmpPrevNode <> nil then TmpPrevParentNode := TmpPrevNode.Parent; if TmpPrevParentNode <> nil then if Not TmpPrevParentNode.Expanded then TmpPrevNode := TmpPrevParentNode; end; CurrNode := TmpPrevNode; end; ATreeView.TopItem := PrevNode; except On E: Exception do; end; ATreeView.Items.EndUpdate; end; end; procedure ShowNodeFly(ATreeView: TFlyTreeViewPro; ANode: TFlyNode); var CurrNode: TFlyNode; PrevNode: TFlyNode; TmpPrevNode: TFlyNode; TmpPrevParentNode: TFlyNode; i: Integer; begin if Assigned(ATreeView) and Assigned(ANode) then begin CurrNode := ANode; PrevNode := CurrNode; for i := 1 to Round(ATreeView.Height/30) do if CurrNode <> nil then begin PrevNode := CurrNode; TmpPrevNode := CurrNode.GetPrevVisible; if TmpPrevNode = nil then begin TmpPrevNode := CurrNode.GetPrev; TmpPrevParentNode := nil; if TmpPrevNode <> nil then TmpPrevParentNode := TmpPrevNode.Parent; if TmpPrevParentNode <> nil then if Not TmpPrevParentNode.Expanded then TmpPrevNode := TmpPrevParentNode; end; CurrNode := TmpPrevNode; end; ATreeView.TopItem := PrevNode; end; end; procedure ShowSelectedNode(ATreeView: TTreeView; aShowNode: Boolean = True); {var SelNode: TTreeNode; CurrNode: TTreeNode; PrevNode: TTreeNode; i: Integer;} begin if Assigned(ATreeView) and Assigned(ATreeView.Selected) then begin // Tolik if aShowNode then // ShowNode(ATreeView, ATreeView.Selected) else ATreeView.Selected.Expanded := False; { SelNode := ATreeView.Selected; CurrNode := ATreeView.Selected; PrevNode := CurrNode; for i := 1 to Round(ATreeView.Height/30) do if CurrNode <> nil then begin PrevNode := CurrNode; CurrNode := CurrNode.GetPrevVisible; end; ATreeView.TopItem := PrevNode; } end; end; procedure ShowSelectedNodeFly(ATreeView: TFlyTreeViewPro); begin if Assigned(ATreeView) and Assigned(ATreeView.Selected) then ShowNodeFly(ATreeView, ATreeView.Selected); end; procedure SetTreeNodesToCheckTreeViewRz(ATreeView: TRzCheckTree; ATreeNodes: TTreeNodes); begin if ATreeView <> ATreeNodes.Owner then begin ATreeView.Items.Clear; ATreeView.Items.Assign(ATreeNodes); end; end; function GetTargetNodeForNewList(var AMayOpenProject: Boolean): TTreeNode; var CurrNode: TTreeNode; TrgNode: TTreeNode; function CanNodeHaveList(ANode: TTreeNode; var ACanOpenProject: Boolean): Boolean; var Dat: PObjectData; begin Result := false; ACanOpenProject := false; if Assigned(ANode) then with F_ProjMan do begin Dat := ANode.Data; case Dat.ItemType of itProject: begin if Dat.ObjectID = GSCSBase.CurrProject.CurrID then if GSCSBase.CurrProject.Active then Result := true; if GSCSBase.CurrProject.Active = false then begin ACanOpenProject := true; Result := true; end; end; itDir: if GSCSBase.CurrProject.Active then Result := true; end; end; end; begin Result := nil; AMayOpenProject := false; CurrNode := nil; TrgNode := nil; with F_ProjMan do begin CurrNode := Tree_Catalog.Selected; if CanNodeHaveList(CurrNode, AMayOpenProject) then Result := CurrNode else begin TrgNode := GetTargetNodeForItemType(Tree_catalog.Selected, itList, qmUndef); if CanNodeHaveList(TrgNode, AMayOpenProject) then Result := TrgNode else if GSCSBase.CurrProject.CurrID > 0 then if GSCSBase.CurrProject.Active then if Assigned(GSCSBase.CurrProject.TreeViewNode) then Result := GSCSBase.CurrProject.TreeViewNode; end; {Dat := CurrNode.Data; if (Dat.ItemType = itProject) and (Dat.ObjectID = GSCSBase.CurrProject.CurrID) then Result := CurrNode else begin TrgNode := GetTargetNodeForItemType(Tree_catalog.Selected, itList); Dat := TrgNode.Data; if Assigned(TrgNode) then if ((Dat.ItemType = itProject) and (Dat.ObjectID = GSCSBase.CurrProject.CurrID)) or (Dat.ItemType = itDir) then Result := TrgNode; end; } end; end; procedure FindGroupNodes(AListNode: TTreeNode; var ALineGroupNode: TTreeNode; var AConnGroupNode: TTreeNode); var CurrNode: TTreeNode; begin ALineGroupNode := nil; AConnGroupNode := nil; if AListNode = nil then Exit; //// EXIT //// CurrNode := AlistNode.getFirstChild; while CurrNode <> nil do begin case PObjectData(CurrNode.Data).ItemType of itSCSConnGroup: AConnGroupNode := CurrNode; itSCSLineGroup: ALineGroupNode := CurrNode; end; if (AConnGroupNode <> nil) and (ALineGroupNode <> nil) then Break; //// BREAK ///// CurrNode := CurrNode.getNextSibling; end; end; function GetQueryModeByGDBMode(AGDBMode: TDBKind): TQueryMode; begin Result := qmPhisical; case AGDBMode of bkNormBase: Result := qmPhisical; bkProjectManager: Result := qmMemory; end; end; function GetQueryModeByParentNode(AGDBMode: TDBKind; AParentNode: TTreeNode; ADefQueryMode: TQueryMode): TQueryMode; var ParentDat: PObjectData; begin Result := ADefQueryMode; if AGDBMode = bkProjectManager then begin if AParentNode = nil then Result := qmPhisical else begin ParentDat := AParentNode.Data; if (ParentDat.ItemType = itProjMan) or ((ParentDat.ItemType = itDir) and (ParentDat.QueryMode = qmPhisical)) {or (ParentDat.ItemType = itProject)} then Result := qmPhisical; end; end; end; function GetQueryModeByNode(AGDBMode: TDBKind; AParentNode: TTreeNode; ADefQueryMode: TQueryMode): TQueryMode; var Dat: PObjectData; begin Result := ADefQueryMode; if AGDBMode = bkProjectManager then begin if AParentNode = nil then Result := qmPhisical else begin Dat := AParentNode.Data; if (Dat.ItemType = itProjMan) or (Dat.ItemType = itProject) or (Dat.QueryMode = qmPhisical) then Result := qmPhisical; end; end; end; procedure ClearcxImage(AImage: TcxImage); //var //i, j: Integer; begin if Assigned(AImage) then begin if AImage.Picture.Graphic <> nil then AImage.Picture.Graphic := nil; //AImage.Canvas.Canvas.Lock; //try //AImage.Picture.Bitmap.LoadFromStream(nil); //AImage.Picture.Bitmap.Free; //AImage.Picture.Bitmap := TBitmap.Create; //AImage.Picture.Free; //AImage.Picture := TPicture.Create; //AImage.Picture.Bitmap.FreeImage; //AImage.Clear; //for i := 2 to AImage.Width - 3 do // for j := 2 to AImage.Height - 3 do // AImage.Canvas.Pixels[i, j] := clWhite; //for i := 0 to AImage.Picture.Bitmap.Width - 1 do // for j := 0 to AImage.Picture.Bitmap.Height - 1 do // AImage.Picture.Bitmap.Canvas.Pixels[i, j] := clWhite; //finally // AImage.Canvas.Canvas.Unlock; //end; end; end; function GetSelectedIDsFromCXTableView(ATableView: TcxGridDBTableView): TIntList; var i: Integer; //TableItem: TcxCustomGridTableItem; begin Result := TIntList.Create; try {TableItem := ATableView.DataController.GetItemByFieldName(fnID); if TableItem <> nil then for i := 0 to ATableView.Controller do begin end;} except on E: Exception do AddExceptionToLogEx('GetSelectedIDsFromCXTableView', E.Message); end; end; function GetComponImageIndexByFilling(AIsLineComponent: Integer; AFilling: TFillConnectConObj; AAsConnected: Boolean = false): Integer; begin Result := 0; case AIsLineComponent of biTrue: case AFilling of foBusy: begin if AAsConnected then Result := tciiConnectedComponLineFill else Result := tciiComponLineFill; end; foEmpty: Result := tciiComponLineNoFill; foPartEmpty: begin if AAsConnected then Result := tciiConnectedComponLinePartFill else Result := tciiComponLinePartFill; end; else Result := tciiComponLine; end; biFalse: case AFilling of foBusy: begin if AAsConnected then Result := tciiConnectedComponConFill else Result := tciiComponConFill; end; foEmpty: Result := tciiComponConNoFill; foPartEmpty: begin if AAsConnected then Result := tciiConnectedComponConPartFill else Result := tciiComponConPartFill; end; else Result := tciiComponCon; end; end; end; function GetImageIndexNoConnected(AImageIndex: Integer): Integer; begin Result := AImageIndex; if AImageIndex = tciiConnectedComponLineFill then Result := tciiComponLineFill else if AImageIndex = tciiConnectedComponLinePartFill then Result := tciiComponLinePartFill else if AImageIndex = tciiConnectedComponConFill then Result := tciiComponConFill else if AImageIndex = tciiConnectedComponConPartFill then Result := tciiComponConPartFill; end; function GetInterfaceImageIndesByIsBusy(AIsBusy: Integer): Integer; begin Result := tciiInterface; case AIsBusy of biTrue: Result := tciiInterfaceFill; biFalse: Result := tciiInterfaceNoFill; end; end; function GetRadioGrpBoxIntVal(const aObjs: array of TObject; const aVals: array of Integer; aDefVal: Integer): Integer; var i: Integer; begin Result := aDefVal; for i := 0 to Length(aObjs) - 1 do if TObject(aObjs[i]) is TRzRadioButton then begin if TRzRadioButton(aObjs[i]).Checked then begin Result := aVals[i]; Break; //// BREAK //// end; end; end; procedure InitDynArrayOfObject(var aTrgArray: TObjectArray; const aArray: array of TObject); var i: Integer; begin SetLength(aTrgArray, Length(aArray)); for i := 0 to Length(aArray) - 1 do aTrgArray[i] := aArray[i]; end; procedure InitDynArrayOfInt(var aTrgArray: TIntegerArray; const aArray: array of Integer); var i: Integer; begin SetLength(aTrgArray, Length(aArray)); for i := 0 to Length(aArray) - 1 do aTrgArray[i] := aArray[i]; end; procedure LoadObjectIconToCXImage(AImage: TcxImage; AIDIcon, AObjectIconType: Integer; ADBMode: TDBKind = bkNormBase); var Bitmap: TBitmap; begin ClearcxImage(AImage); Bitmap := nil; Bitmap := GetObjIcon(AIDIcon, '', AObjectIconType, ADBMode); if Assigned(Bitmap) then begin //AImage.Picture.Bitmap.Free; AImage.Picture.Bitmap := Bitmap; end; end; function LoadInterfPositionsToMenuItem(AMenuItem: TMenuItem; AInterface: TObject; AOnClick: TNotifyEvent): Boolean; var i: Integer; MenuItem: TMenuItem; InterfPosition: TSCSInterfPosition; Positions: TList; procedure AddMenuItem(const ACapt: String; ATag: Integer); begin MenuItem := TMenuItem.Create(AMenuItem.Owner); MenuItem.Caption := ACapt; MenuItem.OnClick := AOnClick; MenuItem.Tag := ATag; AMenuItem.Add(MenuItem); end; function ComparePos(Item1, Item2: Pointer): Integer; begin Result := CompareValue(TSCSInterfPosition(Item1).FromPos, TSCSInterfPosition(Item2).FromPos); end; begin Result := false; if (TSCSInterface(AInterface).ComponentOwner.IsLine = biTrue) then begin // Чистим подпункты for i := AMenuItem.Count - 1 downto 0 do begin MenuItem := AMenuItem.Items[i]; AMenuItem.Remove(MenuItem); MenuItem.Free; end; if TSCSInterface(AInterface).BusyPositions.Count > 0 then begin Positions := TList.Create; Positions.Assign(TSCSInterface(AInterface).BusyPositions); Positions.Sort(@ComparePos); AddMenuItem(cBaseCommon77, Integer(AInterface)); AddMenuItem('-', 0); for i := 0 to Positions.Count - 1 do begin InterfPosition := TSCSInterfPosition(Positions[i]); AddMenuItem(IntToStr(InterfPosition.FromPos)+' - '+IntToStr(InterfPosition.ToPos), Integer(InterfPosition)); //MenuItem := TMenuItem.Create(AMenuItem.Owner); //MenuItem.Caption := IntToStr(InterfPosition.FromPos)+' - '+IntToStr(InterfPosition.ToPos); //MenuItem.OnClick := AOnClick; //MenuItem.Tag := Integer(InterfPosition); //AMenuItem.Add(MenuItem); end; Result := true; Positions.Free; end; end; end; procedure SetCxCurrencyEditProperties(aProps: TcxCustomEditProperties); begin TcxCurrencyEditProperties(aProps).DisplayFormat := GetDisplayFormatForFloat; TcxCurrencyEditProperties(aProps).DecimalPlaces := FloatPrecision; end; procedure SetCheckBoxStyleByVal(const aObj: TObject; aVal: Boolean); begin if aObj is TRzCheckBox then begin if TRzCheckBox(aObj).Checked <> aVal then TRzCheckBox(aObj).Font.Color := clBlue else TRzCheckBox(aObj).Font.Color := clBlack; end; end; procedure SetRadioGrpBoxIntVal(const aObjs: array of TObject; const aVals: array of Integer; aVal: Integer; aWithoutEvent:Boolean=false); var i: Integer; begin for i := 0 to Length(aObjs) - 1 do if TObject(aObjs[i]) is TRzRadioButton then if aWithoutEvent then SetValueToRzRadioButtonAsNoChange(TRzRadioButton(aObjs[i]), false) else TRzRadioButton(aObjs[i]).Checked := false; for i := 0 to Length(aVals) - 1 do if aVals[i] = aVal then begin if TObject(aObjs[i]) is TRzRadioButton then begin if aWithoutEvent then SetValueToRzRadioButtonAsNoChange(TRzRadioButton(aObjs[i]), true) else TRzRadioButton(aObjs[i]).Checked := true; end; Break; //// BREAK //// end; end; procedure SetRadioGrpBoxStyleByIntVal(const aObjs: array of TObject; const aVals: array of Integer; aVal: Integer); var i: Integer; begin for i := 0 to Length(aObjs) - 1 do if TObject(aObjs[i]) is TRzRadioButton then begin TRzRadioButton(aObjs[i]).Font.Color := clBlack; if TRzRadioButton(aObjs[i]).Checked then if aVals[i] <> aVal then TRzRadioButton(aObjs[i]).Font.Color := clBlue else TRzRadioButton(aObjs[i]).Font.Color := clBlack; end; end; procedure SetValueToCXRadioBottonAsNoChange(ARadioButton: TcxRadioButton; AValue: Boolean); var SavedOnChange: TNotifyEvent; begin SavedOnChange := ARadioButton.OnClick; ARadioButton.OnClick := nil; try ARadioButton.Checked := AValue; finally ARadioButton.OnClick := SavedOnChange; end; end; procedure SetValueToCXTextEditAsNoChange(ATextEdit: TcxTextEdit; const AValue: String); var SavedOnChange: TNotifyEvent; begin SavedOnChange := ATextEdit.Properties.OnChange; ATextEdit.Properties.OnChange := nil; try ATextEdit.Text := AValue; finally ATextEdit.Properties.OnChange := SavedOnChange; end; end; procedure SetValueToRzRadioButtonAsNoChange(ARadioButton: TRZRadioButton; AValue: Boolean); var SavedOnClick: TNotifyEvent; begin SavedOnClick := ARadioButton.OnClick; ARadioButton.OnClick := nil; try ARadioButton.Checked := AValue; finally ARadioButton.OnClick := SavedOnClick; end; end; procedure ShowPathByInterfPosition(AObject{, AInterf, AInterfPos}: TObject); var InterfPath: TInterfPath; InterfPos: TSCSInterfPosition; i: Integer; TraceList: TList; ptrID: ^Integer; PosFrom, PosTo: Integer; begin try InterfPath := nil; //if AInterfPos <> nil then //begin // InterfPos := TSCSInterfPosition(AInterfPos); // InterfPath := InterfPos.InterfOwner.GetInterfPath(InterfPos.FromPos, InterfPos.ToPos, nil, true); //end //else //if Assigned(AInterf) and InputRange(ApplicationName, cBaseCommon78, PosFrom, PosTo) then // InterfPath := TSCSInterface(AInterf).GetInterfPath(PosFrom, PosTo, nil, true); if AObject is TSCSInterfPosition then begin InterfPos := TSCSInterfPosition(AObject); InterfPath := InterfPos.InterfOwner.GetInterfPath(InterfPos.FromPos, InterfPos.ToPos, true); end else if (AObject is TSCSInterface) and InputRange(ApplicationName, cBaseCommon78, PosFrom, PosTo) then InterfPath := TSCSInterface(AObject).GetInterfPath(PosFrom, PosTo, true); TraceList := TList.Create; if InterfPath <> nil then for i := 0 to InterfPath.Components.Count - 1 do begin GetZeroMem(ptrID, SizeOf(Integer)); ptrID^ := TSCSComponent(InterfPath.Components[i]).GetFirstParentCatalog.SCSID; TraceList.Add(ptrID); end; SelectTraceInCAD(TraceList); //Tolik 03/05/2019 -- //TraceList.Free; FreeList(TraceList); // except on E: Exception do AddExceptionToLogEx('ShowPathByInterfPosition', E.Message); end; end; procedure BitmapToNormalSize(ABitmap: TBitmap; AMaxSideSize: Integer); var PxCount: Integer; ZoomOut: Double; begin // Определяем кол-во пикселей, выходящее за границы PxCount := ABitmap.Height - AMaxSideSize; if PxCount < (ABitmap.Width - AMaxSideSize) then PxCount := ABitmap.Width - AMaxSideSize; if PxCount > 0 then begin // Определяем в сколько раз нужно уменьшить ZoomOut := (AMaxSideSize + PxCount) / AMaxSideSize; StretchBitmap(ABitmap, Round(ABitmap.Height/ZoomOut), Round(ABitmap.Width/ZoomOut)); //ABitmap.Height := AMaxSideSize; //ABitmap.Width := AMaxSideSize; end; end; procedure StretchBitmap(ABitmap: TBitmap; AHeight, AWidth: Integer); var TmpBitmap: TBitmap; bRect: TRect; begin TmpBitmap := TBitmap.Create; TmpBitmap.Height := AHeight; TmpBitmap.Width := AWidth; bRect := Rect(0, 0, TmpBitmap.Width, TmpBitmap.Height); TmpBitmap.Canvas.StretchDraw(bRect, ABitmap); ABitmap.Assign(TmpBitmap); TmpBitmap.Free; end; function CheckInterfIsUse(AFormBase: TForm; AIDComponent, AIDInterfRel, ANumPair: Integer): Boolean; var InterfPairList: TIntList; i: Integer; begin Result := false; with TF_Main(AFormBase) do begin if ANumPair < 1 then begin InterfPairList := TIntList.Create; InterfPairList.Add(AIDInterfRel); end else InterfPairList := DM.GetIDInterfListByNumPair(AIDComponent, ANumPair); try if InterfPairList <> nil then case GDBMode of bkNormBase: begin ChangeSQLQuery(DM.scsQ, ' SELECT COUNT(*) As Cnt FROM INTERFOFINTERF_RELATION '+ ' WHERE (ID_INTERF_REL = :ID_INTERF) or '+ '(ID_INTERF_TO = :ID_INTERF) '); for i := 0 to InterfPairList.Count - 1 do begin DM.scsQ.Close; DM.scsQ.SetParamAsInteger('ID_Interf', InterfPairList[i]); DM.scsQ.ExecQuery; if DM.scsQ.GetFNAsInteger('Cnt') > 0 then begin Result := true; Break; ///// BREAK ///// end; end; end; bkprojectmanager: begin for i := 0 to InterfPairList.Count - 1 do if GSCSBase.CurrProject.CheckInterfaceInUse(InterfPairList[i]) then begin Result := true; Break; ///// BREAK ///// end; end; end; finally FreeAndNil(InterfPairList); end; end; end; // ##### Определяет, использ-ся ли интерфейс ##### function IsUseInterfRelInMemTable(AFormBase: TForm; AMemTable_Interf: TkbmMemTable; AMakeEdit: TMakeEdit; AShowMessage: Boolean): Boolean; var ID_Component, ID_InterfRel, NumPair: Integer; IsPort: Integer; //strIDInterfrel: String; ActName: String; SubstanceName: String; MessCapt: String; MessQuestion: String; MessageStyle: Uint; MessgRes: Integer; //isUse: Boolean; //i: Integer; //InterfPairList: TIntList; //ptrInterfID: ^Integer; begin Result := false; try //isUse := false; //InterfPairList := nil; //InterfPairList := nil; if AMemTable_Interf.Active = false then Exit; //// EXIT //// ID_InterfRel := AMemTable_Interf.FieldByName(fnID).AsInteger; ID_Component := AMemTable_Interf.FieldByName(fnIDComponent).AsInteger; IsPort := AMemTable_Interf.FieldByName(fnIsPort).AsInteger; NumPair := 0; if IsPort = biFalse then NumPair := AMemTable_Interf.FieldByName(fnNumPair).AsInteger; case IsPort of biTrue: SubstanceName := cNamePort; biFalse: SubstanceName := cNameInterface; end; MessgRes := -1; MessQuestion := '.'+#13+#10+ cQuastTurnToThis+' '+SubstanceName+' '+cQuastInDirectoryInterface; MessageStyle := MB_ICONQUESTION or MB_YESNO; case AMakeEdit of meEdit: begin ActName := cActNameToChange; MessCapt := cActNameEditing+' ' + SubstanceName + cSufixA; end; meDel : begin ActName := cActNameToDelete; MessCapt := cActNameDeleting+' ' + SubstanceName + cSufixA; end; end; //strIDInterfrel := IntToStr(ID_InterfRel); with TF_Main(AFormBase) do begin //*** Если попытка изменения/ удаления интерфейса комплектующей (не своего) if AMemTable_Interf.FieldByName('isNative').AsBoolean = false then begin if AShowMessage then MessgRes := MessageModal(cImpossible+' '+ ActName +' '+ SubstanceName +' '+cOfComplect + MessQuestion, MessCapt, MessageStyle); Result := true; end; if Not Result then if CheckInterfIsUse(AFormBase, ID_Component, ID_InterfRel, NumPair) then begin if AShowMessage then MessgRes := MessageModal(cImpossible+' '+ ActName + ' '+ SubstanceName +' '+ cSinceHeUse + MessQuestion, MessCapt, MessageStyle); Result := true; end; //*** Перейти на порт/интерфейс в справочниках if MessgRes = IDYES then ShowSpravochnikForInterface(AFormBase, AMemTable_Interf); {if NumPair < 1 then begin InterfPairList := TIntList.Create; InterfPairList.Add(ID_InterfRel); end else InterfPairList := DM.GetIDInterfListByNumPair(ID_Component, NumPair); try if InterfPairList <> nil then case GDBMode of bkNormBase: begin ChangeSQLQuery(DM.scsQ, ' SELECT COUNT(*) As Cnt FROM INTERFOFINTERF_RELATION '+ ' WHERE (ID_INTERF_REL = :ID_INTERF) or '+ '(ID_INTERF_TO = :ID_INTERF) '); for i := 0 to InterfPairList.Count - 1 do begin DM.scsQ.Close; DM.scsQ.SetParamAsInteger('ID_Interf', InterfPairList[i]); DM.scsQ.ExecQuery; if DM.scsQ.GetFNAsInteger('Cnt') > 0 then begin isUse := true; Break; ///// BREAK ///// end; end; end; bkprojectmanager: begin for i := 0 to InterfPairList.Count - 1 do if GSCSBase.CurrProject.CheckInterfaceInUse(InterfPairList[i]) then begin isUse := true; Break; ///// BREAK ///// end; end; end; if isUse then begin //MessageModal(0, PChar('Нельзя '+ ActName + // ' '+ SubstanceName +' т.к он используется '), PChar(MessCapt), // MB_ICONINFORMATION or MB_OK); MessageModal('Нельзя '+ ActName + ' '+ SubstanceName +' т.к он используется ', MessCapt, MB_ICONINFORMATION or MB_OK); Result := true; end; finally FreeAndNil(InterfPairList); end; } end; except on E: Exception do AddExceptionToLog('isUseInterfRel: '+E.Message); end; end; function IsUseInterfRelInPortInterfRels(AInterfRelMemTable, APortInterfRelMemTable: TkbmMemTable; AMakeEdit: TMakeEdit; AShowMessage: Boolean): Boolean; var IDInterfRel: Integer; NameInterface: String; PortInterfRelRecNo: Integer; SavedDsrc: TDataSource; ActName: String; begin Result := false; IDInterfRel := AInterfRelMemTable.FieldByName(fnID).AsInteger; NameInterface := AInterfRelMemTable.FieldByName(fnName).AsString; PortInterfRelRecNo := APortInterfRelMemTable.RecNo; SavedDsrc := nil; try SavedDsrc := APortInterfRelMemTable.MasterSource; APortInterfRelMemTable.MasterSource := nil; APortInterfRelMemTable.First; while Not APortInterfRelMemTable.Eof do begin if APortInterfRelMemTable.FieldByName(fnIDInterfRel).AsInteger = IDInterfRel then begin ActName := ''; case AMakeEdit of meEdit: ActName := cActNameToChange; meDel: ActName := cActNameToDelete; end; if AShowMessage then MessageModal(cImpossible+' '+ActName+' '+cNameInterface+' "'+NameInterface+'", '+cThatRelatedWithPort, ApplicationName, MB_ICONINFORMATION or MB_OK); Result := True; Break; ///// BREAK ///// end; APortInterfRelMemTable.Next; end; {APortMemTable.First; while Not APortMemTable.Eof do begin APortInterfRelMemTable.First; while Not APortInterfRelMemTable.Eof do begin if APortInterfRelMemTable.FieldByName(fnIDInterfRel).AsInteger = AIDInterfRel then begin Result := True; Break; ///// BREAK ///// end; APortInterfRelMemTable.Next; end; APortMemTable.Next; end;} finally APortInterfRelMemTable.MasterSource := SavedDsrc; end; end; // Tolik -- 14/06/2016 -- // старая закомменчена (см ниже) function GetInterfaceNormInfo(AInterface: TObject): TList; var ptrInterfaceNormInfo: PInterfaceNormInfo; i: Integer; Interf: TSCSInterface; Proj: TSCSProject; SprInterf: TNBInterface; SprInterfaceNorm: TNBInterfaceNorm; begin {Result.ID := 0; Result.IDInterface := 0; Result.IDNBNorm := 0; Result.Expense := 0; Result.InterfaceIsBusy := 0;} Result := nil; if AInterface = nil then Exit; ///// EXIT ///// Result := TList.Create; Interf := TSCSInterface(AInterface); case TF_Main(Interf.ActiveForm).GDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, 'select * from '+tnInterfaceNorms+' '+ 'where (id_interface = '''+IntToStr(TSCSInterface(AInterface).ID_Interface)+''')'); while Not scsQSelect.Eof do begin if scsQSelect.GetFNAsInteger(fnInterfaceIsBusy) = TSCSInterface(AInterface).IsBusy then if scsQSelect.GetFNAsInteger(fnIDNBNorm) > 0 then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := scsQSelect.GetFNAsInteger(fnID); ptrInterfaceNormInfo.IDInterface := scsQSelect.GetFNAsInteger(fnIDInterface); //ptrInterfaceNormInfo.IDNBNorm := scsQSelect.GetFNAsInteger(fnIDNBNorm); //ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuidNB); ptrInterfaceNormInfo.Expense := scsQSelect.GetFNAsFloat(fnExpense); ptrInterfaceNormInfo.InterfaceIsBusy := scsQSelect.GetFNAsInteger(fnInterfaceIsBusy); Result.Add(ptrInterfaceNormInfo); end; scsQSelect.Next; end; ChangeSQLQuery(scsQSelect, 'select GUID from '+tnNBNorms+' '+ 'where id in (select '+fnIDNBNorm+' from '+tnInterfaceNorms+' '+ 'where id = :id )'); for i := 0 to Result.Count - 1 do begin ptrInterfaceNormInfo := Result[i]; scsQSelect.Close; scsQSelect.SetParamAsInteger(fnID, ptrInterfaceNormInfo.ID); scsQSelect.ExecQuery; ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuid); end; end; bkProjectManager: begin SprInterf := nil; Proj := TSCSProject(Interf.ComponentOwner.GetTopParentCatalog); if Proj <> nil then //SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, true); SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, false); if SprInterf <> nil then for i := 0 to SprInterf.InterfaceNorms.Count - 1 do begin SprInterfaceNorm := TNBInterfaceNorm(SprInterf.InterfaceNorms[i]); if SprInterfaceNorm.InterfaceIsBusy = Interf.IsBusy then if (SprInterfaceNorm.GUIDComponentType = '') or (SprInterfaceNorm.GUIDComponentType = Interf.ComponentOwner.GUIDComponentType) then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := SprInterfaceNorm.ID; ptrInterfaceNormInfo.IDInterface := SprInterfaceNorm.IDInterface; ptrInterfaceNormInfo.GUIDNBNorm := SprInterfaceNorm.GuidNBNorm; ptrInterfaceNormInfo.Expense := SprInterfaceNorm.Expense; ptrInterfaceNormInfo.InterfaceIsBusy := SprInterfaceNorm.InterfaceIsBusy; ptrInterfaceNormInfo.InterfaceType := Interf.TypeI; Result.Add(ptrInterfaceNormInfo); end; end; end; end; end; function GetInterfaceNormInfo(AInterface: TObject; getFirstCableTracing : Boolean): TList; //function GetInterfaceNormInfo(AInterface: TObject; getFirstCableTracing: Boolean): TList; var ptrInterfaceNormInfo: PInterfaceNormInfo; i: Integer; Interf: TSCSInterface; Proj: TSCSProject; SprInterf: TNBInterface; SprInterfaceNorm: TNBInterfaceNorm; begin {Result.ID := 0; Result.IDInterface := 0; Result.IDNBNorm := 0; Result.Expense := 0; Result.InterfaceIsBusy := 0;} Result := nil; if AInterface = nil then Exit; ///// EXIT ///// Result := TList.Create; Interf := TSCSInterface(AInterface); case TF_Main(Interf.ActiveForm).GDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, 'select * from '+tnInterfaceNorms+' '+ 'where (id_interface = '''+IntToStr(TSCSInterface(AInterface).ID_Interface)+''')'); while Not scsQSelect.Eof do begin if scsQSelect.GetFNAsInteger(fnInterfaceIsBusy) = TSCSInterface(AInterface).IsBusy then if scsQSelect.GetFNAsInteger(fnIDNBNorm) > 0 then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := scsQSelect.GetFNAsInteger(fnID); ptrInterfaceNormInfo.IDInterface := scsQSelect.GetFNAsInteger(fnIDInterface); //ptrInterfaceNormInfo.IDNBNorm := scsQSelect.GetFNAsInteger(fnIDNBNorm); //ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuidNB); ptrInterfaceNormInfo.Expense := scsQSelect.GetFNAsFloat(fnExpense); ptrInterfaceNormInfo.InterfaceIsBusy := scsQSelect.GetFNAsInteger(fnInterfaceIsBusy); Result.Add(ptrInterfaceNormInfo); end; scsQSelect.Next; end; ChangeSQLQuery(scsQSelect, 'select GUID from '+tnNBNorms+' '+ 'where id in (select '+fnIDNBNorm+' from '+tnInterfaceNorms+' '+ 'where id = :id )'); for i := 0 to Result.Count - 1 do begin ptrInterfaceNormInfo := Result[i]; scsQSelect.Close; scsQSelect.SetParamAsInteger(fnID, ptrInterfaceNormInfo.ID); scsQSelect.ExecQuery; ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuid); end; end; bkProjectManager: begin SprInterf := nil; Proj := TSCSProject(Interf.ComponentOwner.GetTopParentCatalog); if Proj <> nil then //SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, true); SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, false); if (SprInterf <> nil) and (Interf.isBusy = 1) then begin for i := 0 to SprInterf.InterfaceNorms.Count - 1 do begin SprInterfaceNorm := TNBInterfaceNorm(SprInterf.InterfaceNorms[i]); if GetFirstCableTracing then begin if (SprInterfaceNorm.InterfaceIsBusy <> 0) then begin if (SprInterfaceNorm.GUIDComponentType = '') or (SprInterfaceNorm.GUIDComponentType = Interf.ComponentOwner.GUIDComponentType) then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := SprInterfaceNorm.ID; ptrInterfaceNormInfo.IDInterface := SprInterfaceNorm.IDInterface; ptrInterfaceNormInfo.GUIDNBNorm := SprInterfaceNorm.GuidNBNorm; ptrInterfaceNormInfo.Expense := SprInterfaceNorm.Expense; ptrInterfaceNormInfo.InterfaceIsBusy := SprInterfaceNorm.InterfaceIsBusy; ptrInterfaceNormInfo.InterfaceType := Interf.TypeI; Result.Add(ptrInterfaceNormInfo); end; end; end else begin if ((SprInterfaceNorm.InterfaceIsBusy <> 2) and (SprInterfaceNorm.InterfaceIsBusy <> 0)) then begin if (SprInterfaceNorm.GUIDComponentType = '') or (SprInterfaceNorm.GUIDComponentType = Interf.ComponentOwner.GUIDComponentType) then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := SprInterfaceNorm.ID; ptrInterfaceNormInfo.IDInterface := SprInterfaceNorm.IDInterface; ptrInterfaceNormInfo.GUIDNBNorm := SprInterfaceNorm.GuidNBNorm; ptrInterfaceNormInfo.Expense := SprInterfaceNorm.Expense; ptrInterfaceNormInfo.InterfaceIsBusy := SprInterfaceNorm.InterfaceIsBusy; ptrInterfaceNormInfo.InterfaceType := Interf.TypeI; Result.Add(ptrInterfaceNormInfo); end; end; end; end; end else if ((SprInterf <> nil) and (Interf.isBusy = 0)) then begin for i := 0 to SprInterf.InterfaceNorms.Count - 1 do begin SprInterfaceNorm := TNBInterfaceNorm(SprInterf.InterfaceNorms[i]); SprInterfaceNorm := TNBInterfaceNorm(SprInterf.InterfaceNorms[i]); if SprInterfaceNorm.InterfaceIsBusy = 0 then begin if (SprInterfaceNorm.GUIDComponentType = '') or (SprInterfaceNorm.GUIDComponentType = Interf.ComponentOwner.GUIDComponentType) then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := SprInterfaceNorm.ID; ptrInterfaceNormInfo.IDInterface := SprInterfaceNorm.IDInterface; ptrInterfaceNormInfo.GUIDNBNorm := SprInterfaceNorm.GuidNBNorm; ptrInterfaceNormInfo.Expense := SprInterfaceNorm.Expense; ptrInterfaceNormInfo.InterfaceIsBusy := SprInterfaceNorm.InterfaceIsBusy; ptrInterfaceNormInfo.InterfaceType := Interf.TypeI; Result.Add(ptrInterfaceNormInfo); end; end; end; end; end; end; end; (* function GetInterfaceNormInfo(AInterface: TObject): TList; var ptrInterfaceNormInfo: PInterfaceNormInfo; i: Integer; Interf: TSCSInterface; Proj: TSCSProject; SprInterf: TNBInterface; SprInterfaceNorm: TNBInterfaceNorm; begin {Result.ID := 0; Result.IDInterface := 0; Result.IDNBNorm := 0; Result.Expense := 0; Result.InterfaceIsBusy := 0;} Result := nil; if AInterface = nil then Exit; ///// EXIT ///// Result := TList.Create; Interf := TSCSInterface(AInterface); case TF_Main(Interf.ActiveForm).GDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, 'select * from '+tnInterfaceNorms+' '+ 'where (id_interface = '''+IntToStr(TSCSInterface(AInterface).ID_Interface)+''')'); while Not scsQSelect.Eof do begin if scsQSelect.GetFNAsInteger(fnInterfaceIsBusy) = TSCSInterface(AInterface).IsBusy then if scsQSelect.GetFNAsInteger(fnIDNBNorm) > 0 then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := scsQSelect.GetFNAsInteger(fnID); ptrInterfaceNormInfo.IDInterface := scsQSelect.GetFNAsInteger(fnIDInterface); //ptrInterfaceNormInfo.IDNBNorm := scsQSelect.GetFNAsInteger(fnIDNBNorm); //ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuidNB); ptrInterfaceNormInfo.Expense := scsQSelect.GetFNAsFloat(fnExpense); ptrInterfaceNormInfo.InterfaceIsBusy := scsQSelect.GetFNAsInteger(fnInterfaceIsBusy); Result.Add(ptrInterfaceNormInfo); end; scsQSelect.Next; end; ChangeSQLQuery(scsQSelect, 'select GUID from '+tnNBNorms+' '+ 'where id in (select '+fnIDNBNorm+' from '+tnInterfaceNorms+' '+ 'where id = :id )'); for i := 0 to Result.Count - 1 do begin ptrInterfaceNormInfo := Result[i]; scsQSelect.Close; scsQSelect.SetParamAsInteger(fnID, ptrInterfaceNormInfo.ID); scsQSelect.ExecQuery; ptrInterfaceNormInfo.GUIDNBNorm := scsQSelect.GetFNAsString(fnGuid); end; end; bkProjectManager: begin SprInterf := nil; Proj := TSCSProject(Interf.ComponentOwner.GetTopParentCatalog); if Proj <> nil then //SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, true); SprInterf := Proj.Spravochnik.GetInterfaceWithAssign(Interf.GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, false); if SprInterf <> nil then for i := 0 to SprInterf.InterfaceNorms.Count - 1 do begin SprInterfaceNorm := TNBInterfaceNorm(SprInterf.InterfaceNorms[i]); if SprInterfaceNorm.InterfaceIsBusy = Interf.IsBusy then if (SprInterfaceNorm.GUIDComponentType = '') or (SprInterfaceNorm.GUIDComponentType = Interf.ComponentOwner.GUIDComponentType) then begin GetZeroMem(ptrInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrInterfaceNormInfo.ID := SprInterfaceNorm.ID; ptrInterfaceNormInfo.IDInterface := SprInterfaceNorm.IDInterface; ptrInterfaceNormInfo.GUIDNBNorm := SprInterfaceNorm.GuidNBNorm; ptrInterfaceNormInfo.Expense := SprInterfaceNorm.Expense; ptrInterfaceNormInfo.InterfaceIsBusy := SprInterfaceNorm.InterfaceIsBusy; ptrInterfaceNormInfo.InterfaceType := Interf.TypeI; Result.Add(ptrInterfaceNormInfo); end; end; end; end; end; *) function GetInterfaceGenderName(AGenderIndex: String): String; begin Result := ''; if AGenderIndex = '0' then Result := cBaseCommon25_1; if AGenderIndex = '1' then Result := cBaseCommon25_2; end; function GetInterfGenderInverse(AGender: Integer): Integer; begin Result := -1; if AGender = gtMale then Result := gtFemale else if AGender = gtFemale then Result := gtMale; end; procedure ShowMessageAboutCheckCableCanalElemnts(const AComponentName: String; AElementsCount: Integer); begin if AElementsCount > 0 then begin MessageModal(cbMessage7+' "'+AComponentName+'".', ApplicationName, MB_ICONINFORMATION or MB_OK); end; end; //*** Отобразить спарвочник для интерфейса из MemTable procedure ShowSpravochnikForInterface(AForm: TForm; AMemTable: TkbmMemTable); var IDInterface: Integer; GUIDInterface: String; Spravochnick: TSpravochnik; OldName: String; CurrSprInterface: TNBInterface; RecNo: Integer; i: Integer; DBMode: TDBKind; begin Spravochnick := nil; IDInterface := -1; GUIDInterface := ''; IDInterface := AMemTable.FieldByName(fnIDInterface).AsInteger; GUIDInterface := AMemTable.FieldByName(fnGuidInterface).AsString; OldName := AMemTable.FieldByName(fnName).AsString; //*** Показать справочник DBMode := TF_Main(AForm).GDBMode; case DBMode of bkNormBase: begin Spravochnick := TF_Main(AForm).GSCSBase.NBSpravochnik; TF_Main(AForm).F_CaseForm.GUseMemTable := AMemTable; TF_Main(AForm).F_CaseForm.GIDToLocate := IDInterface; TF_Main(AForm).F_CaseForm.Execute(vkInterface, fmView); end; bkProjectManager: begin if ShowCurrProjectProperties(vkInterface, GUIDInterface) then Spravochnick := TF_Main(AForm).GSCSBase.CurrProject.Spravochnik; end; end; //*** Применить новое изменения справочника на AMemTable if Spravochnick <> nil then begin CurrSprInterface := nil; if GUIDInterface <> '' then CurrSprInterface := Spravochnick.GetInterfaceWithAssign(GUIDInterface, F_NormBase.GSCSBase.NBSpravochnik, false, false) else CurrSprInterface := Spravochnick.GetInterfaceByID(IDInterface); if CurrSprInterface <> nil then if CurrSprInterface.Name <> OldName then begin if AMemTable.RecordCount > 0 then // Tolik 27/12/2019 -- begin RecNo := AMemTable.RecNo; AMemTable.DisableControls; try for i := 0 to AMemTable.RecordCount - 1 do begin AMemTable.RecNo := i+1; if ((GUIDInterface <> '') and (AMemTable.FieldByName(fnGuidInterface).AsString = GUIDInterface)) or (AMemTable.FieldByName(fnIDInterface).AsInteger = IDInterface) then begin AMemTable.Edit; AMemTable.FieldByName(fnName).AsString := CurrSprInterface.Name; AMemTable.Post; end; end; finally AMemTable.RecNo := RecNo; AMemTable.EnableControls; end; end; end; end; end; procedure BaseBeginUpdate; begin //Exit; //#Del if GBaseUpdateHandling then Exit; try if GBaseBeginUpdateCount = 0 then begin GBaseUpdateHandling := true; try Screen.Cursor := crHourGlass; if Assigned(F_ProjMan) then with F_ProjMan do begin LockTreeAndGrid(true); //EnableScrollBar(Tree_Catalog.Handle, SB_BOTH, ESB_DISABLE_BOTH); //SetTimer(F_ProjMan.Handle, TimerIDRefreshPMLockedTree, 1000, @RefreshPMLockedTree); Tree_Catalog.OnChanging := nil; Tree_Catalog.OnChange := nil; end; finally GBaseUpdateHandling := false; end; end; Inc(GBaseBeginUpdateCount); except on E: Exception do AddExceptionToLog('BaseBeginUpdate: '+E.Message); end; end; procedure BaseEndUpdate; var RefreshFlag: Boolean; begin //Exit; //#Del if GBaseUpdateHandling then Exit; // Tolik -- 04/11/2016 RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try if GBaseBeginUpdateCount > 0 then Dec(GBaseBeginUpdateCount); if GBaseBeginUpdateCount = 0 then begin if Assigned(F_ProjMan) then with F_ProjMan do begin GBaseUpdateHandling := true; try if F_ChoiceConnectSide.Timer_DefineObjetsParamsInCAD.Enabled then F_ChoiceConnectSide.Timer_DefineObjetsParamsInCADTimer(F_ChoiceConnectSide.Timer_DefineObjetsParamsInCAD); //KillTimer(F_ProjMan.Handle, TimerIDRefreshPMLockedTree); //EnableScrollBar(Tree_Catalog.Handle, SB_BOTH, ESB_ENABLE_BOTH); LockTreeAndGrid(false); Tree_Catalog.OnChanging := Tree_CatalogChanging; Tree_Catalog.OnChange := Tree_CatalogChange; Tree_Catalog.Selected := Tree_Catalog.Selected; if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin //F_ChoiceConnectSide.RefreshCurrListComponents; //if Assigned(Tree_Catalog.Selected) then // Tree_Catalog.OnChange(Tree_Catalog, Tree_Catalog.Selected); RefreshNode(true); end; //ShowSelectedNode(Tree_Catalog); finally GBaseUpdateHandling := false; end; end; Screen.Cursor := crDefault; end; except on E: Exception do AddExceptionToLog('BaseEndUpdate: '+E.Message); end; // Tolik -- 04/11/2016 GCanrefreshCad := RefreshFlag; if GCadForm <> nil then RefreshCad(GCadForm.PCad); // end; procedure BeginDevideLine; begin Inc(GLockConnectDisconnectCount); end; procedure EndDevideLine; begin if GLockConnectDisconnectCount > 0 then Dec(GLockConnectDisconnectCount); end; procedure BeginDublicateCADObjects; begin if GLockConnectDisconnectCount = 0 then begin GIsDublicatingCADObjects := true; if F_ProjMan <> nil then if F_ProjMan.GSCSBase <> nil then if F_ProjMan.GSCSBase.CurrProject <> nil then begin F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects.Clear; F_ProjMan.GSCSBase.CurrProject.IDsNewObjects.Clear; end; end; Inc(GLockConnectDisconnectCount); end; procedure EndDublicateCADObjects; var i, j, k: Integer; IDSrcObject: Integer; IDTrgObject: Integer; SrcObject: TSCSCatalog; TrgObject: TSCSCatalog; SrcObjectOfJoinedCompon: TSCSCatalog; TrgObjectOfJoinedCompon: TSCSCatalog; IDTrgObjectOfJoinedCompon: Integer; IndexSrcObjectOfJoinedCompon: Integer; SrcComponent: TSCSComponent; JoinedToSrcComponent: TSCSComponent; IDNewComponent: Integer; NewComponent: TSCSComponent; JoinedToNewComponent: TSCSComponent; NewObjectComponents: TSCSComponents; NewObjectJoinedComponents: TSCSComponents; begin if GLockConnectDisconnectCount > 0 then begin Dec(GLockConnectDisconnectCount); if GLockConnectDisconnectCount = 0 then begin GIsDublicatingCADObjects := false; NewObjectComponents := TSCSComponents.Create(false); NewObjectJoinedComponents := TSCSComponents.Create(false); Inc(GLockDefineObjectParamsCount); BeginProgress; try //*** Сдублировать компоненты объектов for i := 0 to F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects.Count - 1 do begin IDSrcObject := F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects[i]; IDTrgObject := F_ProjMan.GSCSBase.CurrProject.IDsNewObjects[i]; DublicateObjectComponents(IDSrcObject, IDTrgObject); end; //*** Запомнить подключения исходных компонент for i := 0 to F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects.Count - 1 do begin IDSrcObject := F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects[i]; IDTrgObject := F_ProjMan.GSCSBase.CurrProject.IDsNewObjects[i]; SrcObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(IDSrcObject); TrgObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(IDTrgObject); if (SrcObject <> nil) and (TrgObject <> nil) then for j := 0 to SrcObject.ComponentReferences.Count - 1 do begin SrcComponent := SrcObject.ComponentReferences[j]; for k := 0 to SrcComponent.JoinedComponents.Count - 1 do begin JoinedToSrcComponent := SrcComponent.JoinedComponents[k]; //*** Компоненты не внутри одной компоненты if SrcComponent.GetTopComponent <> JoinedToSrcComponent.GetTopComponent then begin SrcObjectOfJoinedCompon := JoinedToSrcComponent.GetFirstParentCatalog; //*** Объект поключенной компоненты попадает в список дублированных IndexSrcObjectOfJoinedCompon := F_ProjMan.GSCSBase.CurrProject.IDsSrcObjects.IndexOf(SrcObjectOfJoinedCompon.SCSID); if IndexSrcObjectOfJoinedCompon <> -1 then begin //*** Найти сдублированный объект, по подкл.ченному к исходному IDTrgObjectOfJoinedCompon := F_ProjMan.GSCSBase.CurrProject.IDsNewObjects[IndexSrcObjectOfJoinedCompon]; if IDTrgObjectOfJoinedCompon <> -1 then begin TrgObjectOfJoinedCompon := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(IDTrgObjectOfJoinedCompon); if TrgObjectOfJoinedCompon <> nil then begin NewComponent := GetComponentByOldIDFromObject(TrgObject, SrcComponent.ID); JoinedToNewComponent := GetComponentByOldIDFromObject(TrgObjectOfJoinedCompon, JoinedToSrcComponent.ID); if (NewComponent <> nil) and (JoinedToNewComponent <> nil) then begin NewObjectComponents.Add(NewComponent); NewObjectJoinedComponents.Add(JoinedToNewComponent); end; end; end; end; end; end; end; end; if (NewObjectComponents.Count > 0) and (NewObjectJoinedComponents.Count > 0) and (NewObjectComponents.Count = NewObjectJoinedComponents.Count) then begin for i := 0 to NewObjectComponents.Count - 1 do begin NewComponent := NewObjectComponents[i]; JoinedToNewComponent := NewObjectJoinedComponents[i]; //*** Проверить не соединялись ли эти компоненты if NewComponent.JoinedComponents.IndexOf(JoinedToNewComponent) = -1 then begin F_ProjMan.F_ChoiceConnectSide.JoinWithDefineSides(NewComponent, JoinedToNewComponent, false); end; end; end; {//*** Подключить компоненты внутри объекта (не компоненты) if (SrcObjectComponent.Count > 0) and (SrcObjectComponent.Count = SrcObjectJoined.Count) then for i := 0 to SrcObjectComponent.Count - 1 do begin SrcComponent := SrcObjectComponent[i]; JoinedToSrcComponent := SrcObjectJoined[i]; NewComponent := nil; JoinedToNewComponent := nil; NewComponent := GetComponentByOldIDFromObject(TrgObject, SrcComponent.ID); if NewComponent <> nil then JoinedToNewComponent := GetComponentByOldIDFromObject(TrgObject, JoinedToSrcComponent.ID); if (NewComponent <> nil) and (JoinedToNewComponent <> nil) then NewComponent.JoinTo(JoinedToNewComponent, -1, -1); end;} finally EndProgress; Dec(GLockDefineObjectParamsCount); FreeAndNil(NewObjectComponents); FreeAndNil(NewObjectJoinedComponents); end; end; end; end; procedure BeginAutoTrace; begin if F_ProjMan <> nil then if F_ProjMan.GSCSBase <> nil then if F_ProjMan.GSCSBase.CurrProject <> nil then if F_ProjMan.GSCSBase.CurrProject.Active then F_ProjMan.GSCSBase.CurrProject.IsAutoTracing := true; end; procedure EndAutoTrace; begin if F_ProjMan <> nil then if F_ProjMan.GSCSBase <> nil then if F_ProjMan.GSCSBase.CurrProject <> nil then if F_ProjMan.GSCSBase.CurrProject.Active then F_ProjMan.GSCSBase.CurrProject.IsAutoTracing := false; end; procedure RefreshPMLockedTree; begin with F_ProjMan do begin if Tree_Catalog.Showing then begin Tree_Catalog.Items.EndUpdate; Tree_Catalog.Items.BeginUpdate; end; end; end; procedure DisableMarking; begin if CheckIsOpenProject(false) then F_ProjMan.GSCSBase.CurrProject.CanGenMarkID := false; end; procedure EnableMarking; begin if CheckIsOpenProject(false) then F_ProjMan.GSCSBase.CurrProject.CanGenMarkID := true; end; function CheckPropSysNameInUOM(const ASysName: String): Boolean; begin Result := false; //Result := (GPropSysNameInUOM.IndexOf(ASysName) <> -1) or // (ASysName = pnOutDiametr); end; function CheckSysNameIsCable(const ASysName: string): Boolean; begin Result := GCompTypeSysNameCables.IndexOf(ASysName) <> -1; //(ASysName = ctsnCable) or (ASysName = ctsnOFCable); end; function CheckSysNameIsCableChannel(const ASysName: string): Boolean; begin Result := GCompTypeSysNameCableChannels.IndexOf(ASysName) <> -1; //(ASysName = ctsnCableChannel); end; function CheckSysNameIsTrunk(const ASysName: string): Boolean; begin Result := (ASysName = ctsnCrossATS) or (ASysName = ctsnDistributionCabinet); end; procedure ChangeCurrList(var AIDCurrList: Integer; ANewIDCurrList: Integer); var //Node: TTreeNode; //Dat: PobjectData; //i: Integer; TopNode: TTreeNode; NewList: TSCSList; procedure CollapseNoSelectListNodes(ARootNode: TTreeNode); var RootDat: PObjectData; ChildNode: TTreeNode; begin if ARootNode = nil then Exit; //// EXIT //// RootDat := ARootNode.Data; if RootDat.ItemType = itList then begin //if ArootNode <> F_ProjMan.Tree_Catalog.Selected then //if ARootNode.Expanded then if PObjectData(ARootNode.Data).ObjectID <> NewList.ID then ArootNode.Expanded := false; if PObjectData(ARootNode.Data).ObjectID = NewList.ID then begin F_ProjMan.GSCSBase.CurrProject.CurrList.TreeViewNode := ARootNode; //##ARootNode.Expand(false); //ARootNode.Expanded := true; end; //*** Не лесть вглубь Листа Exit; ///// EXIT ///// end; ChildNode := nil; ChildNode := ARootNode.GetFirstChild; while ChildNode <> nil do begin CollapseNoSelectListNodes(ChildNode); ChildNode := ChildNode.getNextSibling; end; end; begin try NewList := nil; if AIDCurrList = ANewIDCurrList then Exit; ///// EXIT ///// if F_ProjMan.GSCSBase.CurrProject.IsOpening or F_ProjMan.GSCSBase.CurrProject.IsClousing then Exit; ///// EXIT ///// AIDCurrList := ANewIDCurrList; //F_ProjMan.GListSetting.ChangeList(ANewIDCurrList); F_ProjMan.GSCSBase.CurrProject.SetCurrListByID(ANewIDCurrList); if F_ProjMan.GSCSBase.CurrProject.CurrList <> nil then with F_ProjMan do begin if Assigned(GSCSBase.CurrProject.CurrList) then if Assigned(GSCSBase.CurrProject.CurrList.TreeViewNode) then begin //18.06.2013 Tree_Catalog.Selected := GSCSBase.CurrProject.CurrList.TreeViewNode; SelectNodeDirect(GSCSBase.CurrProject.CurrList.TreeViewNode); //ShowSelectedNode(Tree_Catalog); end; NewList := GSCSBase.CurrProject.CurrList; TopNode := nil; TopNode := GetTopNode; if TopNode <> nil then CollapseNoSelectListNodes(TopNode); {for i := 0 to Tree_Catalog.Items.Count - 1 do begin Node := Tree_Catalog.Items[i]; if PObjectData(Node.Data).ItemType = itList then if Node <> Tree_Catalog.Selected then if Node.Expanded then Node.Expanded := false; end;} end; except on E: Exception do AddExceptionToLog('ChangeCurrList: '+E.Message); end; end; procedure ChangeCurrProject(var AIDCurrProject: Integer; ANewIDCurrProject: Integer); var TopNode: TTreeNode; ProjNode: TTreeNode; ChildNode: TTreeNode; PrevCldNode: TTreeNode; ListNode: TTreeNode; Dat: PobjectData; i: Integer; //OldTick: Cardinal; //DeltaTick: Cardinal; OpenResult: TopenProjectResult; begin AIDCurrProject := ANewIDCurrProject; GIDLastList := -1; ListNode := nil; //F_ProjMan.GSCSBase.CurrProject.CurrID := ANewIDCurrProject; //OldTick := GetTickCount; OpenResult := F_ProjMan.GSCSBase.CurrProject.Open(ANewIDCurrProject); //DeltaTick := GetTickCount - OldTick; //DeltaTick := GetTickCount - OldTick; if opsFoul in OpenResult.OpenProjectState then begin if opsNoEnoughGDI in OpenResult.OpenProjectState then begin if MessageDlg(ApplicationName+' '+cBaseCommon26, mtConfirmation, [mbYes, mbNo], 0) = mrYes then {$if Defined(ES_GRAPH_SC)} Application.Terminate; {$else} ExitProcess(0); {$ifend} end else if opsInUse in OpenResult.OpenProjectState then ShowMessageByType(0, smtDisplay, cBaseCommon27+' "'+OpenResult.UserName+'".'+#10+#13+ cBaseCommon28+' '+ DateTimeToStr(OpenResult.UserDateTime), Application.Title, MB_OK or MB_ICONINFORMATION); end else if opsSuccessful in OpenResult.OpenProjectState then // Tolik 24/03/2017 -- begin // with F_ProjMan do begin TopNode := nil; ProjNode := nil; //TopNode := GetTopNode; //if TopNode <> nil then begin for i := 0 to Tree_Catalog.Items.Count - 1 do begin ProjNode := Tree_Catalog.Items[i]; Dat := ProjNode.Data; if (Dat <> nil) and (Dat.ItemType = itProject) then if Dat.ObjectID <> ANewIDCurrProject then begin ProjNode.Expanded := false; ChildNode := ProjNode.getFirstChild; while ChildNode <> nil do begin PrevCldNode := ChildNode; ChildNode := ChildNode.getNextSibling; DeleteNode(PrevCldNode); end; end; //ProjNode := ProjNode.GetNextSibling; end; { //*** Пререйти на первый Лист if Assigned(GSCSBase.CurrProject.CurrList) then begin if Assigned(GSCSBase.CurrProject.CurrList.TreeViewNode) then ListNode := GSCSBase.CurrProject.CurrList.TreeViewNode else ListNode := FindComponOrDirInTree(GSCSBase.CurrProject.CurrList.ID, false); if Assigned(ListNode) then Tree_Catalog.Selected := ListNode; end; } end; end; if (F_Navigator <> nil) and F_Navigator.Showing then ReAssignNavigatorParams; end; //*** Пререйти на первый Лист //if F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count > 0 then // ChangeCurrList(GIDLastList, F_ProjMan.GSCSBase.CurrProject.ProjectLists[0].CurrID); end; function CheckIsOpenProject(AMessage: Boolean): Boolean; begin Result := false; if F_ProjMan <> nil then // Tolik 22/03/2019 if F_ProjMan.GSCSBase <> nil then begin if F_ProjMan.GSCSBase.CurrProject <> nil then if Not F_ProjMan.GSCSBase.CurrProject.Active then begin Result := false; if AMessage then ShowMessageByType(0, smtDisplay, cBaseCommon29, Application.Title, MB_OK or MB_ICONINFORMATION); end else Result := true; end; end; function CheckIsOpenProjectBeforeOperation(AMessage: Boolean): Boolean; begin Result := false; if CheckIsOpenProject(false) then Result := true else if AMessage then ShowMessageByType(0, smtDisplay, cBaseCommon49, Application.Title, MB_OK or MB_ICONINFORMATION); end; function CheckIsOpenListBeforeOperation(ACheckNormal, AMessage: Boolean): Boolean; begin Result := CheckIsOpenProjectBeforeOperation(AMessage); if Result then if (F_ProjMan.GSCSBase.CurrProject.CurrList = nil) or Not F_ProjMan.GSCSBase.CurrProject.CurrList.Active or Not F_ProjMan.GSCSBase.CurrProject.CurrList.OpenedInCAD or (ACheckNormal and (F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.ListType <> lt_Normal)) then begin Result := false; if AMessage then ShowMessageByType(0, smtDisplay, CActiveListNotExistMessage, Application.Title, MB_OK or MB_ICONINFORMATION); end; end; function GenCurrProjTableID(AGeneratorIndex: Integer; AIncrement: Integer = 1): Integer; begin Result := 0; with F_ProjMan do if Assigned(GSCSBase) then if GSCSBase.Active then if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then Result := GSCSBase.CurrProject.GenIDByGeneratorIndex(AGeneratorIndex, AIncrement); end; function GenNewSCSID: Integer; var MaxSCSID: Integer; begin Result := 0; try //Result := F_ProjMan.DM.FLastKatalogSCSID + 1; Result := GenCurrProjTableID(giKatalogSCSID); except on E: Exception do AddExceptionToLog('GenNewSCSID: '+E.Message); end; end; function GenNewListID: Integer; begin //Result := 0; Result := GenNewSCSID; {try Result := 0; with F_ProjMan.DM do begin SetSQLToQuery(scsQSelect, ' select MAX(scs_id) from katalog where id_item_type = '''+IntToStr(itList)+''' '); Result := scsQSelect.FN('MAX').AsInteger + 1; end; except on E: Exception do AddExceptionToLog('GenNewListID: '+E.Message); end; } end; function GenNewSCSObjectID: Integer; begin Result := GenNewSCSID; {try Result := 0; with F_ProjMan.DM do begin SetSQLToQuery(scsQSelect, ' select MAX(scs_id) from katalog '+ ' where (id_item_type = '''+IntToStr(itSCSConnector)+''') or (id_item_type = '''+IntToStr(itSCSLine)+''') '); Result := scsQSelect.FN('MAX').AsInteger + 1; end; except on E: Exception do AddExceptionToLog('GenNewSCSObjectID: '+E.Message); end; } end; function GenObjectNewIndex(AObject: TObject; ASCSObjectKind: TSCSObjectKind): Integer; var IndexFieldName: String; ProjectID: Integer; NewIndex: Integer; CurrObject: TSCSCatalog; CurrList: TSCSList; begin Result := -1; try case ASCSObjectKind of okPointObject: IndexFieldName := 'index_conn'; okLine: IndexFieldName := 'index_line'; okConnector: IndexFieldName := 'index_joiner'; end; with F_ProjMan.DM do begin {//*** Найти ID Проекта данного объекта SetSQLToQuery(scsQSelect, ' select project_id from katalog '+ ' where id = '''+IntToStr(AIDObject)+''' '); ProjectID := scsQSelect.FN('project_id').AsInteger; } if AObject = nil then Exit; ///// EXIT ///// CurrObject := TSCSCatalog(AObject); CurrList := nil; CurrList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(CurrObject.ListID); if CurrList = nil then Exit; ///// EXIT ///// //*** Определить Новый индекс //NewIndex := GetCatalogFieldValueAsInteger(AListID, 'scs_id', IndexFieldName, qmMemory) + 1; NewIndex := 0; case ASCSObjectKind of okPointObject: begin Inc(CurrList.IndexPointObj); NewIndex := CurrList.IndexPointObj; CurrObject.IndexPointObj := NewIndex; end; okLine: begin Inc(CurrList.IndexLine); NewIndex := CurrList.IndexLine; CurrObject.IndexLine := NewIndex; end; okConnector: begin Inc(CurrList.IndexConnector); NewIndex := CurrList.IndexConnector; CurrObject.IndexConnector := NewIndex; end; end; CurrObject.MarkID := NewIndex; {<#MemTableClear#> //*** Внести новый индекс объекта в базу // # удалить UpdateCatalogFieldAsInteger(CurrObject.ID, NewIndex, fnID, IndexFieldName, qmMemory); UpdateCatalogFieldAsInteger(CurrObject.ID, NewIndex, fnID, 'mark_id', qmMemory); ////*** Установка нового сгенерированного значения на генерир. поле Листа UpdateCatalogFieldAsInteger(CurrList.CurrID, NewIndex, fnSCSID, IndexFieldName, qmMemory); } { //*** Определить Новый индекс NewIndex := GetCatalogFieldValueAsInteger(AListID, 'scs_id', IndexFieldName, qmMemory) + 1; //*** Внести новый индекс объекта в базу // # удалить UpdateCatalogFieldAsInteger(AIDObject, NewIndex, fnID, IndexFieldName, qmMemory); UpdateCatalogFieldAsInteger(AIDObject, NewIndex, fnID, 'mark_id', qmMemory); //*** Установка нового сгенерированного значения на генерир. поле Листа UpdateCatalogFieldAsInteger(AListID, NewIndex, 'scs_id', IndexFieldName, qmMemory); } //*** Определить Новый индекс {SetSQLToQuery(scsQSelect, ' select MAX('+IndexFieldName+') from katalog '+ ' where List_id = '''+IntTostr(AListID)+''' '); NewIndex := scsQSelect.FN('MAX').AsInteger + 1;} {SetSQLToQuery(scsQSelect, ' select '+IndexFieldName+' from katalog '+ ' where scs_id = '''+IntTostr(AListID)+''' '); NewIndex := scsQSelect.GetFNAsInteger(IndexFieldName) + 1; //*** Внести новый индекс объекта в базу // # удалить SetSQLToQuery(scsQOperat, ' update katalog set '+IndexFieldName+' = '''+IntTostr(NewIndex)+''' '+ ' where id = '''+IntTostr(AIDObject)+''' '); SetSQLToQuery(scsQOperat, ' update katalog set mark_id = '''+IntTostr(NewIndex)+''' '+ ' where id = '''+IntTostr(AIDObject)+''' '); //*** Установка нового сгенерированного значения на генерир. поле Листа SetSQLToQuery(scsQOperat, ' update katalog set '+IndexFieldName+' = '''+IntTostr(NewIndex)+''' '+ ' where scs_id = '''+IntTostr(AListID)+''' '); } Result := NewIndex; end; except on E: Exception do AddExceptionToLog('GenObjectNewIndex: '+E.Message); end; end; function GenNewComponentCypher(AQuery1, AQuery2: TpFIBQuery): String; const SymCount = 14; var NewCypher: String; IsUnique: Boolean; // Tolik 28/08/2019 -- //Old, Curr: Cardinal; Old, Curr: DWord; // Query1SQL: String; Query2SQL: String; function GenCypher: String; var CypherID: Integer; Cypher: String; i: Integer; begin Result := ''; Cypher := ''; CypherID := 0; with F_NormBase.DM do begin //SetSQLToQuery(scsQSelect, ' select * from get_new_component_cypher'); //CypherID := scsQSelect.GetFNAsInteger('new_cypher'); AQuery1.Close; AQuery1.ExecQuery; CypherID := AQuery1.Fields[0].AsInteger; //AQuery1.FN('new_cypher').AsInteger; end; if CypherID <> 0 then begin Cypher := IntToStr(CypherID); while Length(Cypher) < 14 do Cypher := '0' + Cypher; Insert('-', Cypher, 4); Insert('-', Cypher, 9); Insert('-', Cypher, 14); Cypher := '90' + Cypher; end; Result := Cypher; end; begin Result := ''; NewCypher := ''; IsUnique := false; //*** Запрос на получения нового индекса для шифра //Query1SQL := 'select * from get_new_component_cypher'; Query1SQL := 'SELECT GEN_ID('+gnComponentCypher+', 1) as '+fnID+' FROM '+tnRDBDatabase+''; AQuery1.Close; if Not((AQuery1.SQL.Count = 1) and (AQuery1.SQL[0] = Query1SQL)) then SetSQLToFIBQuery(AQuery1, Query1SQL, false); //*** Запрос на проверку существования шифра Query2SQL := 'select ID from component where CYPHER = :CYPHER'; AQuery2.Close; if Not((AQuery2.SQL.Count = 1) and (AQuery2.SQL[0] = Query2SQL)) then SetSQLToFIBQuery(AQuery2, Query2SQL, false); Old := GetTickCount; while Not IsUnique do begin NewCypher := GenCypher; with F_NormBase.DM do begin AQuery2.Close; AQuery2.Params[0].AsString := NewCypher; //ParamByName(fnCypher).AsString := NewCypher; AQuery2.ExecQuery; //SetSQLToQuery(scsQSelect, 'select count(*) from component where CYPHER = '''+NewCypher+''''); //if scsQSelect.GetFNAsInteger(fnCount) = 0 then //if AQuery2.FN(fnID).AsInteger = 0 then if AQuery2.Fields[0].AsInteger = 0 then begin Result := NewCypher; IsUnique := true; end; end; end; Curr := GetTickCount - Old; Curr := GetTickCount - Old; //F_NormBase.DM.Query.Close; //F_NormBase.DM.Query_Select.Close; {Cypher := ''; CypherID := 0; with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select * from get_new_component_cypher'); CypherID := scsQSelect.GetFNAsInteger('new_cypher'); end; if CypherID <> 0 then begin Cypher := IntToStr(CypherID); while Length(Cypher) < 14 do Cypher := '0' + Cypher; Insert('-', Cypher, 4); Insert('-', Cypher, 9); Insert('-', Cypher, 14); Cypher := 'S1' + Cypher; end; Result := Cypher; } end; function GenNewComponentWholeID: Integer; begin Result := 0; try Result := GenCurrProjTableID(giComponentWholeID); {with F_ProjMan.DM do begin Query_Select.Close; Query_Select.SQL.Text := 'select * from gen_new_component_whole_id'; Query_Select.ExecQuery; Result := Query_Select.FN('new_whole_id').AsInteger; end;} except on E: Exception do AddExceptionToLog('GenNewComponentWholeID: '+E.Message); end; end; function GenNewCompRelSortID(AForm: TForm; AIDParentComponent: integer): Integer; //var i: Integer; var SCSComponent: TSCSComponent; begin Result := 0; if AForm <> nil then with TF_Main(AForm) do begin //SetSQLToQuery(scsQSelect, ' select MAX(SORT_ID) As Max_Sort_ID from component_relation where id_component = '''+IntToStr(AIDParentComponent)+''' '); //Result := scsQSelect.GetFNAsInteger('Max_Sort_ID') + 1; case GDBMode of bkNormBase: Result := 1 + DM.GetCompRelMaxFieldValueByFilter(fnSortID, 'id_component = '''+IntToStr(AIDParentComponent)+''''); bkProjectManager: begin SCSComponent := GSCSBase.CurrProject.GetComponentFromReferences(AIDParentComponent); if Assigned(SCSComponent) then Result := SCSComponent.GenCompRelSortID; end; end; end; end; procedure AddStrToMemTable(AMemTable: TkbmMemTable; AFieldName, AStr: String); begin if AMemTable.Active then begin AMemTable.Append; AMemTable.FieldByName(AFieldName).AsString := AStr; AMemTable.Post; end; end; procedure AssignDataSetRecord(AMakeEdit: TMakeEdit; ATrg, ASrc: TDataSet; const AFieldsToSkip: String); var i: Integer; TrgField: TField; SrcField: TField; FieldsToSkip: TStringList; begin if AMakeEdit = meMake then ATrg.Append else if AMakeEdit = meEdit then ATrg.Edit; if ATrg.State <> dsBrowse then begin FieldsToSkip := nil; if AFieldsToSkip <> '' then FieldsToSkip := GetStringsFromStr(AnsiUpperCase(AFieldsToSkip), ';', false); for i := 0 to ATrg.Fields.Count - 1 do begin TrgField := ATrg.Fields[i]; if (FieldsToSkip = nil) or (FieldsToSkip.IndexOf(AnsiUpperCase(TrgField.FieldName)) = -1) then begin SrcField := ASrc.FindField(TrgField.FieldName); if SrcField <> nil then begin if TrgField.IsBlob then begin end else TrgField.Value := SrcField.Value; end; end; end; ATrg.Post; if FieldsToSkip <> nil then FreeAndNil(FieldsToSkip); end; end; procedure AssignDataSetRecordFromFIBQuery(AMakeEdit: TMakeEdit; ATrg: TDataSet; ASrc: TpFIBQuery); var i: Integer; TrgField: TField; SrcField: TFIBXSQLVAR; begin if AMakeEdit = meMake then ATrg.Append else if AMakeEdit = meEdit then ATrg.Edit; if ATrg.State <> dsBrowse then begin for i := 0 to ATrg.Fields.Count - 1 do begin TrgField := ATrg.Fields[i]; SrcField := nil; if ASrc.FieldIndex[TrgField.FieldName] <> -1 then SrcField := ASrc.FN(TrgField.FieldName); if SrcField <> nil then begin if TrgField.IsBlob then begin end else TrgField.Value := SrcField.Value; end; end; ATrg.Post; end; end; procedure AssignMemTable(ATrg, ASrc: TkbmMemTable; AActivateTrg: Boolean); begin try ATrg.Active := false; ATrg.FieldDefs.Clear; ATrg.FieldDefs.Assign(ASrc.FieldDefs); ATrg.LoadFromDataSet(ASrc, []); if AActivateTrg then ATrg.Active := true; except on E: Exception do AddExceptionToLogEx('AssignMemTable', E.Message); end; end; procedure ClearFieldsInMemTable(AMemTable, ADetailMemTable: TkbmMemTable); begin try if ADetailMemTable <> nil then begin DisconnectDetailMemTable(ADetailMemTable); ADetailMemTable.Active := false; ADetailMemTable.FieldDefs.Clear; end; AMemTable.Active := false; AMemTable.FieldDefs.Clear; except on E: Exception do AddExceptionToLogEx('ClearFieldsInMemTable', E.Message); end; end; procedure ConnectDetailMemTable(AMasterSource: TDataSource; ADetailMemTable: TkbmMemTable; const AMasterField, ADetailField: String); begin ADetailMemTable.DetailFields := ADetailField; ADetailMemTable.MasterFields := AMasterField; ADetailMemTable.MasterSource := AMasterSource; end; procedure DisconnectDetailMemTable(AMemTable: TkbmMemTable); begin AMemTable.MasterSource := nil; AMemTable.MasterFields := ''; end; procedure CreateMTWithDsrc(AOwner: TComponent; var AMT: TkbmMemTable; var ADsrc: TDataSource; const AMTName, ADsrcName: String); begin AMT := TkbmMemTable.Create(AOwner); AMT.Name := AMTName; ADsrc := TDataSource.Create(AOwner); ADsrc.Name := ADsrcName; ADsrc.DataSet := AMT; end; procedure InputFloatToRelatedZeroFieldInMT(AMemTable: TkbmMemTable; AEditingValue: Double; AEditingFieldName, ARelatedFieldName, AFieldsToZero, AInputPromt: String; AConvertInputedFromUOMToM: Boolean; AUOM: Integer); var EditingValue: Double; RelatedValue: Double; FieldNamesToZero: TStringList; i: Integer; begin EditingValue := AEditingValue; // если в редактируемое поле ввели 0, то оставляем все как было if EditingValue = 0 then begin EditingValue := AMemTable.FieldByName(AEditingFieldName).AsFloat; AMemTable.Edit; AMemTable.FieldByName(AEditingFieldName).AsFloat := EditingValue; AMemTable.Post; end else begin RelatedValue := AMemTable.FieldByName(ARelatedFieldName).AsFloat; // еслисвязанное поле = 0, то вводим его значение if RelatedValue = 0 then begin RelatedValue := InputForm(F_NormBase, ApplicationName, AInputPromt, 1, dtFloat); RelatedValue := Abs(RelatedValue); if RelatedValue = 0 then EditingValue := AMemTable.FieldByName(AEditingFieldName).AsFloat else if AConvertInputedFromUOMToM then RelatedValue := FloatInUOM(RelatedValue, AUOM, umM); end; AMemTable.Edit; AMemTable.FieldByName(AEditingFieldName).AsFloat := EditingValue; AMemTable.FieldByName(ARelatedFieldName).AsFloat := RelatedValue; if RelatedValue <> 0 then begin FieldNamesToZero := GetStringsFromStr(AFieldsToZero, ';', false); for i := 0 to FieldNamesToZero.Count - 1 do AMemTable.FieldByName(FieldNamesToZero[i]).AsFloat := 0; FreeAndNil(FieldNamesToZero); end; AMemTable.Post; end; end; procedure DefineMTPriceFields(AMT: TkbmMemTable; APriceFields: TStringList; AOldCurr, ANewCurr: TCurrency); var //BookmarkStr: String; BookmarkStr: TBookMark; PriceValue: Double; i: Integer; FName: String; begin if AMT <> nil then begin //BookmarkStr := AMT.Bookmark; BookmarkStr := AMT.GetBookmark; AMT.DisableControls; try AMT.First; while Not AMT.Eof do begin for i := 0 to APriceFields.Count - 1 do begin FName := APriceFields[i]; PriceValue := AMT.FieldByName(FName).AsFloat; if PriceValue > 0 then begin if AMT.State <> dsEdit then AMT.Edit; AMT.FieldByName(FName).AsFloat := GetPriceAfterChangeCurrency(PriceValue, AOldCurr, ANewCurr, valEpsilonCurrency); end; end; if AMT.State = dsEdit then AMT.Post; AMT.Next; end; //AMT.Bookmark := BookmarkStr; AMT.GotoBookmark(BookmarkStr); AMT.FreeBookmark(BookmarkStr); finally AMT.EnableControls; end; end; end; procedure DefineTablePriceFields(ATableName: String; APriceFields: TStringList; AOldCurr, ANewCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery; AIDListToDefine: TIntList); const Epsilon = 20; var IDList: TIntList; i, j: Integer; CurrID: Integer; PriceValue: Double; PriceValues: TStringList; CanUpdateRecord: Boolean; begin IDList := nil; PriceValues := TStringList.Create; try try if AIDListToDefine = nil then begin IDList := GetAllIDsFromTable(ATableName, AQSelect); //SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ATableName, '', nil, fnID)); //IntFIBFieldToIntList(IDList, AQSelect, fnID); end else begin IDList := TIntList.Create; IDList.Assign(AIDListToDefine); end; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ATableName, fnID+' = :'+fnID, APriceFields, ''), false); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, fnID+' = :'+fnID, APriceFields, ''), false); for i := 0 to IDList.Count - 1 do begin CurrID := IDList.Items[i]; //*** Отобрать поля с ценами записи по ID = CurrID AQSelect.Close; AQSelect.ParamByName(fnID).AsInteger := CurrID; AQSelect.ExecQuery; if AQSelect.RecordCount > 0 then begin //*** Значения полей преобразуем и записываем в массив PriceValues.Clear; CanUpdateRecord := false; for j := 0 to APriceFields.Count - 1 do begin PriceValue := AQSelect.FN(APriceFields[j]).AsFloat; if PriceValue > 0 then begin PriceValue := GetPriceAfterChangeCurrency(PriceValue, AOldCurr, ANewCurr, Epsilon); CanUpdateRecord := true; end; PriceValues.Add(FloatToStr(PriceValue)); end; AQSelect.Close; //*** Обновить поля цен if CanUpdateRecord then begin AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := CurrID; for j := 0 to APriceFields.Count - 1 do AQOperat.ParamByName(APriceFields[j]).AsFloat := StrToFloat_My(PriceValues[j]); AQOperat.ExecQuery; end; end; end; except on E: Exception do AddExceptionToLog('DefineTablePriceFields: '+E.Message); end; finally FreeAndNil(PriceValues); if IDList <> nil then FreeAndNil(IDList); end; end; function CalcNormResourceCount(AUserCount, ALength, AExpenseForLength, ACountForPoint, AStepOfPoint: Double; ARoundIfExpenseForLength: Boolean): Double; begin Result := AUserCount; if ALength > 0 then begin if AExpenseForLength > 0 then begin Result := ALength * RoundCP(AExpenseForLength); if ARoundIfExpenseForLength then Result := Round(Result); end else if (ACountForPoint > 0) and (AStepOfPoint > 0) then begin //Определяем общее количество точек Result := RoundUp(ALength / AStepOfPoint); //Trunc(ALength / AStepOfPoint); // так как в линии две точки, то прибавляем 2 if Result > 0 then Result := Result - 1; Result := Result + 2; // учитываем количество на точку Result := Result * ACountForPoint; end; end; end; procedure ChengeCurrencyRatiosWithPrices(AOldCurr, ANewCurr, ANewSecondCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery); const Epsilon = 20; procedure RefreshPrices; var NormResoureRelPriceFields: TStringList; NormsPriceFields: TStringList; ResourcesPriceFields: TStringList; IDAllCompons: TIntList; IDDisabledCompons: TIntList; begin try try //*** определить цены компонент IDAllCompons := GetAllIDsFromTable(tnComponent, AQSelect); IDDisabledCompons := GetCompoIDsInCatalogCurrencies(AQSelect); if IDDisabledCompons <> nil then IDAllCompons.Assign(IDDisabledCompons, laXor); ChangeComponsCurrencyRatiosWithPrices(IDAllCompons, AOldCurr, ANewCurr, AQSelect, AQOperat); //*** Определить цены норм и ресурсов из справочников NormResoureRelPriceFields := TStringList.Create; NormResoureRelPriceFields.Add(fnCost); NormsPriceFields := TStringList.Create; //23.09.2010 NormsPriceFields.Add(fnPrice); NormsPriceFields.Add(fnPricePerTime); ResourcesPriceFields := TStringList.Create; ResourcesPriceFields.Add(fnPrice); ResourcesPriceFields.Add(fnAdditionalPrice); DefineTablePriceFields('nb_norm_resource_rel', NormResoureRelPriceFields, AOldCurr, ANewCurr, AQSelect, AQOperat, nil); DefineTablePriceFields(tnNBNorms, NormsPriceFields, AOldCurr, ANewCurr, AQSelect, AQOperat, nil); //23.09.2010 DefineTablePriceFields('nb_resources', ResourcesPriceFields, AOldCurr, ANewCurr, AQSelect, AQOperat, nil); except on E: Exception do AddExceptionToLog('RefreshPrices: '+E.Message); end; finally FreeAndNil(IDAllCompons); if IDDisabledCompons <> nil then FreeAndNil(IDDisabledCompons); FreeAndNil(NormResoureRelPriceFields); FreeAndNil(NormsPriceFields); FreeAndNil(ResourcesPriceFields); end; end; procedure RefreshCurrencyRatios; var IDList: TIntList; CurrID: Integer; i: integer; CurrCurrency: TCurrency; begin if AOldCurr.Ratio <> 0 then begin IDList := TIntList.Create; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCurrency, '', nil, fnID)); IntFIBFieldToIntList(IDList, AQSelect, fnID); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCurrency, fnID+' = :'+fnID, nil, fnRatio), false); for i := 0 to IDList.Count - 1 do begin CurrID := IDList[i]; CurrCurrency := GetCurrencyByID(CurrID, AQSelect); //#Not Del CurrCurrency.Ratio := GetPriceAfterChangeCurrency(CurrCurrency.Kolvo, CurrCurrency, ANewCurr, Epsilon); CurrCurrency.Ratio := GetPriceAfterChangeCurrency(CurrCurrency.Ratio, AOldCurr, ANewCurr, Epsilon); AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := CurrID; AQOperat.ParamByName(fnRatio).AsFloat := CurrCurrency.Ratio; AQOperat.ExecQuery; end; IDList.Free; end; //*** Очистить поля с главной и второй валютой SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCurrency, '', nil, fnMain), false); AQOperat.ParamByName(fnMain).AsInteger := ctSimple; AQOperat.ExecQuery; //*** Установить поля с главной и второй валютой SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCurrency, fnID+' = :'+fnID, nil, fnMain), false); AQOperat.ParamByName(fnID).AsInteger := ANewCurr.ID; AQOperat.ParamByName(fnMain).AsInteger := ctMain; AQOperat.ExecQuery; AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := ANewSecondCurr.ID; AQOperat.ParamByName(fnMain).AsInteger := ctSecond; AQOperat.ExecQuery; end; begin //CorrectCurrency(AOldCurr); if AOldCurr.Ratio <> 0 then RefreshPrices; RefreshCurrencyRatios; end; function ChangeCurrencyMainMT(AMTCurrencies, AMTNorms, AMTResources: TkbmMemTable; const AMainGUID: string): TCurrency; var OldCurrM, CurrM, CurrS: TCurrency; CurrCurrency: TCurrency; //BookmarkStr: String; BookmarkStr: TBookMark; PriceFields: TStringList; begin ZeroMemory(@Result, SizeOf(TCurrency)); if AMainGUID <> '' then begin try ZeroMemory(@OldCurrM, SizeOf(TCurrency)); ZeroMemory(@CurrM, SizeOf(TCurrency)); ZeroMemory(@CurrS, SizeOf(TCurrency)); AMTCurrencies.DisableControls; // BookmarkStr := AMTCurrencies.Bookmark; BookmarkStr := AMTCurrencies.GetBookmark; try if AMTCurrencies.Locate(fnMain, ctMain, []) then OldCurrM := GetCurrencyFromMemTable(AMTCurrencies); if AMTCurrencies.Locate(fnGuid, AMainGUID, []) then CurrM := GetCurrencyFromMemTable(AMTCurrencies); if (CurrM.GUID <> '') and (OldCurrM.GUID <> '') then begin //*** Изменить курсы вадют if AMTCurrencies.Locate(fnMain, ctSecond, []) then begin CurrS := GetCurrencyFromMemTable(AMTCurrencies); // Если на место базовой валюты станет главная //if (CurrS.GUID = AMainGUID) and (AMTCurrencies.Locate(fnGuid, OldCurrM.GUID, [])) then // WriteToMemTable(AMTCurrencies, fnMain, CurrS.Main); end; // Текущей главной валюте устанавливаем новый статус (пусто, или вторая) if AMTCurrencies.Locate(fnGuid, OldCurrM.GUID, []) then WriteToMemTable(AMTCurrencies, fnMain, CurrM.Main); AMTCurrencies.First; while Not AMTCurrencies.Eof do begin CurrCurrency := GetCurrencyFromMemTable(AMTCurrencies); AMTCurrencies.Edit; AMTCurrencies.FieldByName(fnRatio).AsFloat := GetPriceAfterChangeCurrency(CurrCurrency.Ratio, OldCurrM, CurrM, valEpsilonCurrency); if AMTCurrencies.FieldByName(fnGUID).AsString = AMainGUID then AMTCurrencies.FieldByName(fnMain).AsInteger := ctMain; AMTCurrencies.Post; AMTCurrencies.Next; end; if AMTCurrencies.Locate(fnMain, ctMain, []) then Result := GetCurrencyFromMemTable(AMTCurrencies); PriceFields := TStringList.Create; PriceFields.Add(fnPrice); PriceFields.Add(fnPricePerTime); //*** Поменять цены справочных норм DefineMTPriceFields(AMTNorms, PriceFields, OldCurrM, CurrM); //*** Поменять цены справочных ресурсов PriceFields.Clear; PriceFields.Add(fnPrice); DefineMTPriceFields(AMTResources, PriceFields, OldCurrM, CurrM); PriceFields.Free; end; finally //AMTCurrencies.Bookmark := BookmarkStr; AMTCurrencies.GotoBookmark(BookmarkStr); AMTCurrencies.FreeBookmark(BookmarkStr); AMTCurrencies.EnableControls; end; except on E: Exception do AddExceptionToLogEx('ChangeCurrencyMainMT', E.Message); end; end; end; procedure ChangeComponsCurrencyRatiosWithPrices(AIDCompons: TIntList; AOldCurr, ANewCurr: TCurrency; AQSelect, AQOperat: TpFIBQuery); var FieldPrices: TStringList; NormResRelsID: TIntList; ResourcesID: TIntList; NormsID: TIntList; begin if AOldCurr.Ratio <> 0 then begin FieldPrices := TStringList.Create; NormResRelsID := TIntList.Create; ResourcesID := TIntList.Create; NormsID := TIntList.Create; GetComponsResourcesID(AIDCompons, NormResRelsID, ResourcesID, AQSelect); //*** Определить цены компонент FieldPrices.Add(fnPriceSupply); FieldPrices.Add(fnPrice); FieldPrices.Add(fnPriceCalc); DefineTablePriceFields(tnComponent, FieldPrices, AOldCurr, ANewCurr, AQSelect, AQOperat, AIDCompons); FieldPrices.Clear; //NormsPriceFields := TStringList.Create; //NormsPriceFields.Add(fnCost); //NormsPriceFields.Add(fnTotalCost); ////RefreshPriceFields(tnNorms, NormsPriceFields); //DefineTablePriceFields(tnNorms, NormsPriceFields, AOldCurr, ANewCurr, AQSelect, AQOperat, nil, nil); //*** Определить стоимости на связях с ресурсами компонент FieldPrices.Add(fnCost); DefineTablePriceFields(tnNormResourceRel, FieldPrices, AOldCurr, ANewCurr, AQSelect, AQOperat, NormResRelsID); FieldPrices.Clear; FieldPrices.Add(fnPrice); FieldPrices.Add(fnAdditionalPrice); DefineTablePriceFields(tnResources, FieldPrices, AOldCurr, ANewCurr, AQSelect, AQOperat, ResourcesID); FieldPrices.Clear; // Цены норм компонентов //24.09.2010 GetComponsNormsID(AIDCompons, NormsID, AQSelect); FieldPrices.Add(fnPricePerTime); //04.11.2013 FieldPrices.Add(fnPrice); //24.09.2010 DefineTablePriceFields(tnNorms, FieldPrices, AOldCurr, ANewCurr, AQSelect, AQOperat, NormsID); FreeAndNil(FieldPrices); FreeAndNil(NormResRelsID); FreeAndNil(ResourcesID); FreeAndNil(NormsID); end; end; procedure ChangeObjectCurrencyRatiosWithPrices(AIDCatalog: Integer; AOldCurr, ANewCurr, ANewSecondCurr: PObjectCurrencyRel; AQSelect, AQOperat: TpFIBQuery); var FieldPrices: TStringList; IDComponents: TIntList; IDCurrencies: TIntList; begin if (AOldCurr <> nil) and (ANewCurr <> nil) then begin FieldPrices := TStringList.Create; IDComponents := GetCatalogAllComponIDs(AIDCatalog, true, AQSelect); IDCurrencies := TIntList.Create; //*** Отобрать Id-ки валют папки SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnObjectCurrencyRel, fnIDCatalog+' = '''+IntToStr(AIDCatalog)+'''', nil, fnID)); IntFIBFieldToIntList(IDCurrencies, AQSelect, fnID); //*** Определить цены компонент и их ресурсов ChangeComponsCurrencyRatiosWithPrices(IDComponents, AOldCurr.Data, ANewCurr.Data, AQSelect, AQOperat); //FieldPrices.Add(fnPriceSupply); //FieldPrices.Add(fnPrice); //FieldPrices.Add(fnPriceCalc); //DefineTablePriceFields(tnComponent, FieldPrices, AOldCurr.Data, ANewCurr.Data, AQSelect, AQOperat, IDComponents, nil); //FieldPrices.Clear; //*** Изменить значения валют FieldPrices.Add(fnRatio); DefineTablePriceFields(tnObjectCurrencyRel, FieldPrices, AOldCurr.Data, ANewCurr.Data, AQSelect, AQOperat, IDCurrencies); //*** Очистить поля с главной и второй валютой SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnObjectCurrencyRel, fnIDCatalog+' = '''+IntToStr(AIDCatalog)+'''', nil, fnMain), false); AQOperat.ParamByName(fnMain).AsInteger := ctSimple; AQOperat.ExecQuery; //*** Установить поля с главной и второй валютой SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnObjectCurrencyRel, fnID+' = :'+fnID, nil, fnMain), false); if (ANewSecondCurr <> nil) then begin AQOperat.ParamByName(fnID).AsInteger := ANewSecondCurr.ID; AQOperat.ParamByName(fnMain).AsInteger := ctSecond; AQOperat.ExecQuery; end; AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := ANewCurr.ID; AQOperat.ParamByName(fnMain).AsInteger := ctMain; AQOperat.ExecQuery; FreeAndNil(FieldPrices); FreeAndNil(IDComponents); FreeAndNil(IDCurrencies); end; end; procedure ChangePricesByNDS(AOldNDS, ANewNDS: Double; AQSelect, AQOperat: TpFIBQuery); var FldList: TStringList; procedure RefreshPriceFields(ATableName: String; APriceFields: TStringList); var IDList: TIntList; i, j: Integer; CurrID: Integer; PriceValue: Double; PriceValues: TStringList; CanUpdateRecord: Boolean; begin IDList := TIntList.Create; PriceValues := TStringList.Create; try try SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ATableName, '', nil, fnID)); IntFIBFieldToIntList(IDList, AQSelect, fnID); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ATableName, fnID+' = :'+fnID, APriceFields, ''), false); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, fnID+' = :'+fnID, APriceFields, ''), false); for i := 0 to IDList.Count - 1 do begin CurrID := IDList.Items[i]; //*** Отобрать поля с ценами записи по ID = CurrID AQSelect.Close; AQSelect.ParamByName(fnID).AsInteger := CurrID; AQSelect.ExecQuery; if AQSelect.RecordCount > 0 then begin //*** Значения полей преобразуем и записываем в массив PriceValues.Clear; CanUpdateRecord := false; for j := 0 to APriceFields.Count - 1 do begin PriceValue := AQSelect.FN(APriceFields[j]).AsFloat; if PriceValue > 0 then begin PriceValue := GetPriceAfterChangeNDS(PriceValue, AOldNDS, ANewNDS); CanUpdateRecord := true; end; PriceValues.Add(FloatToStr(PriceValue)); end; AQSelect.Close; //*** Обновить поля цен if CanUpdateRecord then begin AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := CurrID; for j := 0 to APriceFields.Count - 1 do AQOperat.ParamByName(APriceFields[j]).AsFloat := StrToFloat_My(PriceValues[j]); AQOperat.ExecQuery; end; end; end; except on E: Exception do AddExceptionToLog('ChangePricesByNDS/RefreshPriceFields: '+E.Message); end; finally FreeAndNil(PriceValues); FreeAndNil(IDList); end; end; begin FldList := TStringList.Create; FldList.Add(fnPrice); FldList.Add(fnPriceCalc); RefreshPriceFields(tnComponent, FldList); FreeAndNil(FldList); end; procedure CorrectCurrency(var ACurrency: TCurrency); begin if ACurrency.Ratio = 0 then begin ACurrency.Ratio := 100; ACurrency.Kolvo := 100; end; end; function GetCompoIDsInCatalogCurrencies(AQSelect: TpFIBQuery): TIntList; var IDCatalogsWithCurrencies: TIntList; IDChildCatalogs: TIntList; IDAllCatalog: TIntList; i: Integer; begin Result := nil; try IDCatalogsWithCurrencies := TIntList.Create; IDAllCatalog := TIntList.Create; //*** Отобрать папки с валютами if CheckExistsTableInBase(AQSelect, tnObjectCurrencyRel) then begin SetSQLToFIBQuery(AQSelect, 'select distinct '+fnIDCatalog+' from '+tnObjectCurrencyRel); IntFIBFieldToIntList(IDCatalogsWithCurrencies, AQSelect, fnIDCatalog); end; //*** Отобрать все подпапки папок с валютами for i := 0 to IDCatalogsWithCurrencies.Count - 1 do begin IDAllCatalog.Add(IDCatalogsWithCurrencies[i]); IDChildCatalogs := GetCatalogAllChildsIDs(IDCatalogsWithCurrencies[i], AQSelect); if IDChildCatalogs <> nil then begin IDAllCatalog.Assign(IDChildCatalogs, laOr); FreeAndNil(IDChildCatalogs); end; end; //*** Отобрать все компоненты выбранных папок Result := GetComponIDsFromCatalogs(IDAllCatalog, AQSelect); FreeAndNil(IDAllCatalog); FreeAndNil(IDCatalogsWithCurrencies); except on E: Exception do AddExceptionToLogEx('GetCompoIDsInCatalogCurrencies', E.Message); end; end; // Tolik 20/12/2019 -- function GetCountryCurrency(AQuery: TpFIBQuery): TCurrency; begin //Zeromemory(@Result, SizeOf(TCurrency)); //with F_NormBase.DM do //begin try SetSQLToFIBQuery(AQuery, getSQLByParams(qtSelect, tnCurrency, fnIsCountry+' = '''+IntToStr(biTrue)+'''', nil, fnAll)); if AQuery.RecordCount > 0 then Result := GetCurrencyFromQuery(AQuery) else Result := GetCurrencyByType(ctMain, AQuery); Except on E: Exception do Zeromemory(@Result, SizeOf(TCurrency)); end; //end; end; { function GetCountryCurrency(AQuery: TpFIBQuery): TCurrency; begin Zeromemory(@Result, SizeOf(TCurrency)); //with F_NormBase.DM do //begin SetSQLToFIBQuery(AQuery, getSQLByParams(qtSelect, tnCurrency, fnIsCountry+' = '''+IntToStr(biTrue)+'''', nil, fnAll)); if AQuery.RecordCount > 0 then Result := GetCurrencyFromQuery(AQuery) else Result := GetCurrencyByType(ctMain, AQuery); //end; end; } function GetCurrenciesNameBriefListFromNB: TStringList; var i: Integer; Spravochnik: TSpravochnik; NBCurrency: TNBCurrency; begin Result := TStringList.Create; try if F_NormBase <> nil then begin Spravochnik := F_NormBase.GetSpravochnik; if Spravochnik <> nil then begin for i := 0 to Spravochnik.Currencies.Count - 1 do begin NBCurrency := TNBCurrency(Spravochnik.Currencies[i]); Result.AddObject(NBCurrency.Data.NameBrief, TObject(NBCurrency.Data.ID)); end; Result.Sort; end; end; except on E: Exception do AddExceptionToLogEx('GetCurrenciesNameBriefListFromNB', E.Message); end; end; function GetCurrencyByFieldValue(AFldByName: String; AFldValue: Variant; AQuery: TpFIBQuery): TCurrency; var ValueStr: String; begin // Tolik 20/12/2019 -- //ZeroMemory(@Result, SizeOf(TCurrency)); // ValueStr := AFldValue; SetSQLToFIBQuery(AQuery, 'select * from currency where '+AFldByName+' = '''+ValueStr+''''); Result := GetCurrencyFromQuery(AQuery); end; function GetCurrencyByID(ACurrencyID: Integer; AQuery: TpFIBQuery): TCurrency; begin Result := GetCurrencyByFieldValue(fnID, ACurrencyID, AQuery); //ZeroMemory(@Result, SizeOf(TCurrency)); //SetSQLToFIBQuery(AQuery, 'select * from currency where id = '''+IntToStr(ACurrencyID)+''''); //Result := GetCurrencyFromQuery(AQuery); end; function GetCurrencyByGUID(ACurrencyGUID: String; AQuery: TpFIBQuery): TCurrency; begin Result := GetCurrencyByFieldValue(fnGUID, ACurrencyGUID, AQuery); end; function GetCurrencyByType(ACurrencyType: Integer; AQuery: TpFIBQuery): TCurrency; begin Result := GetCurrencyByFieldValue(fnMain, ACurrencyType, AQuery); //ZeroMemory(@Result, SizeOf(TCurrency)); //SetSQLToFIBQuery(AQuery, 'select * from currency where main = '''+IntToStr(ACurrencyType)+''''); //Result := GetCurrencyFromQuery(AQuery); end; function GetCurrencyFromDataSet(ADataSet: TpFIBDataSet): TCurrency; begin ZeroMemory(@Result, SizeOf(TCurrency)); try with ADataSet do begin Result.ID := FN(fnID).AsInteger; Result.GUID := FN(fnGUID).AsString; Result.Name := FN(fnName).AsString; Result.NameBrief := FN(fnNameBrief).AsString; Result.Kolvo := FN(fnKolvo).AsInteger; Result.Ratio := FN(fnRatio).AsFloat; Result.Main := FN(fnMain).AsInteger; Result.IsCountry := FN(fnIsCountry).AsInteger; end; except on E: Exception do AddExceptionToLog('GetCurrencyFromDataSet: '+E.Message); end; end; function GetCurrencyFromMemTable(AMemTable: TkbmMemTable): TCurrency; begin ZeroMemory(@Result, SizeOf(TCurrency)); try with AMemTable do begin Result.ID := FieldByName(fnID).AsInteger; Result.GUID := FieldByName(fnGUID).AsString; Result.Name := FieldByName(fnName).AsString; Result.NameBrief := FieldByName(fnNameBrief).AsString; Result.Kolvo := FieldByName(fnKolvo).AsInteger; Result.Ratio := FieldByName(fnRatio).AsFloat; Result.Main := FieldByName(fnMain).AsInteger; Result.IsCountry := FieldByName(fnIsCountry).AsInteger; end; except on E: Exception do AddExceptionToLog('GetCurrencyFromMemTable: '+E.Message); end; end; function GetCurrencyFromQuery(AQuery: TpFIBQuery): TCurrency; begin ZeroMemory(@Result, SizeOf(TCurrency)); try Result.GUID := AQuery.FN(fnGUID).AsString; Result.ID := AQuery.FN(fnID).AsInteger; Result.Name := AQuery.FN(fnName).AsString; Result.NameBrief := AQuery.FN(fnNameBrief).AsString; Result.Kolvo := AQuery.FN(fnKolvo).AsInteger; Result.Ratio := AQuery.FN(fnRatio).AsFloat; Result.Main := AQuery.FN(fnMain).AsInteger; Result.IsCountry := AQuery.FN(fnIsCountry).AsInteger; except on E: Exception do AddExceptionToLog('GetCurrencyFromQuery: '+E.Message); end; end; function GetCurrncyIDFromForm(ACurrCurrnecyID: Integer): Integer; begin Result := -1; Result := F_NormBase.DM.GetCurrencyIDFromGuide(ACurrCurrnecyID, fmMake); end; procedure CreateDefCurrenciesForObject(AIDCatalog: Integer; AQSelect, AQOperat: TpFIBQuery; AFromList: TList = nil); var DefCurrency: TCurrency; ptrObjectCurrency: PObjectCurrencyRel; ptrNewObjectCurrency: PObjectCurrencyRel; NewObjCurrencies: TList; i: Integer; begin NewObjCurrencies := nil; //*** Удалить все валюты для этой папки DeleteObjectCurrencies(AIDCatalog, AQOperat); //*** отобрать все валюты из справочника if AFromList = nil then NewObjCurrencies := GetDefCurrenciesForObject(AIDCatalog, AQSelect) else begin NewObjCurrencies := TList.Create; for i := 0 to AFromList.Count - 1 do begin GetMem(ptrObjectCurrency, SizeOf(TObjectCurrencyRel)); ptrObjectCurrency^ := PObjectCurrencyRel(AFromList[i])^; NewObjCurrencies.Add(ptrObjectCurrency); end; end; //*** Созранить новые валюты папки for i := 0 to NewObjCurrencies.Count - 1 do begin ptrNewObjectCurrency := NewObjCurrencies[i]; ptrNewObjectCurrency.IDCatalog := AIDCatalog; SaveObjectCurrency(meMake, ptrNewObjectCurrency, AQSelect, AQOperat); end; FreeList(NewObjCurrencies); end; procedure CreateDefCurrenciesForObjectsByLevel(AQSelect, AQOperat: TpFIBQuery); var CatalogIDs: TIntList; i: Integer; begin try CatalogIDs := GetCatalogIDsByLevel(dirCurrencyLevel, AQSelect); for i := 0 to CatalogIDs.Count - 1 do begin if GetObjectCurrencyCount(CatalogIDs[i], AQSelect) = 0 then CreateDefCurrenciesForObject(CatalogIDs[i], AQSelect, AQOperat); end; FreeAndNil(CatalogIDs); except on E: Exception do AddExceptionToLogEx('CreateDefCurrenciesForObjectsByLevel', E.Message); end; end; procedure DeleteObjectCurrencies(AIDCatalog: Integer; AQOperat: TpFIBQuery); begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtDelete, tnObjectCurrencyRel, fnIDCatalog+' = '''+IntToStr(AIDCatalog)+'''', nil, '')); end; function GetDefCurrenciesForObject(AIDCatalog: Integer; AQSelect: TpFIBQuery): TList; var ptrNewObjectCurrency: PObjectCurrencyRel; begin Result := TList.Create; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCurrency, '', nil, fnAll)); while Not AQSelect.Eof do begin GetZeroMem(ptrNewObjectCurrency, SizeOf(TObjectCurrencyRel)); ptrNewObjectCurrency.Data := GetCurrencyFromQuery(AQSelect); ptrNewObjectCurrency.IDCatalog := AIDCatalog; ptrNewObjectCurrency.IDCurrency := ptrNewObjectCurrency.Data.ID; Result.Add(ptrNewObjectCurrency); AQSelect.Next; end; end; function GetDefObjectCurrencyByIDCurrency(AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var DefCurrency: TCurrency; begin DefCurrency := GetCurrencyByID(AIDCurrency, AQSelect); if DefCurrency.ID > 0 then begin GetZeroMem(Result, SizeOf(TObjectCurrencyRel)); Result.IDCurrency := DefCurrency.ID; Result.Data := DefCurrency; end; end; function GetDefObjectCurrencyByMainFld(AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var DefCurrency: TCurrency; begin Result := nil; DefCurrency := GetCurrencyByType(AMainValue, AQSelect); if DefCurrency.ID > 0 then begin GetZeroMem(Result, SizeOf(TObjectCurrencyRel)); Result.IDCurrency := DefCurrency.ID; Result.Data := DefCurrency; end; end; function GetObjectCurrencies(AIDCatalog: Integer; AQSelect: TpFIBQuery): TList; var ptrObjectCurrency: PObjectCurrencyRel; i: Integer; begin Result := TList.Create; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnObjectCurrencyRel, fnIDCatalog+' = '''+IntToStr(AIDCatalog)+'''', nil, fnAll)); while Not AQSelect.Eof do begin ptrObjectCurrency := GetObjectCurrencyFromQuery(AQSelect); Result.Add(ptrObjectCurrency); AQSelect.Next; end; //*** Определить GUIDы валют SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCurrency, fnID+' = :'+fnID, nil, fnGUID), false); for i := 0 to Result.Count - 1 do begin ptrObjectCurrency := Result[i]; AQSelect.Close; AQSelect.Params[0].AsInteger := ptrObjectCurrency.IDCurrency; AQSelect.ExecQuery; ptrObjectCurrency.Data.GUID := AQSelect.Fields[0].AsString; end; end; function GetObjectCurrencyCount(AIDCatalog: Integer; AQSelect: TpFIBQuery): Integer; var ConditionCatalogID: String; begin Result := 0; ConditionCatalogID := GetZeroConditionAsNull(fnIDCatalog, AIDCatalog); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnObjectCurrencyRel, ConditionCatalogID, nil, fnCount+'('+fnID+')')); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger; end; function GetObjectCurrencyByIDCurrency(ACatalogID, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; begin Result := GetObjectCurrencyByIntFld(ACatalogID, AIDCurrency, fnIDCurrency, AQSelect); end; function GetObjectCurrencyByCurrencyIDFromList(AIDCurrency: Integer; AList: TList): PObjectCurrencyRel; var i: Integer; ptrObjectCurrency: PObjectCurrencyRel; begin Result := nil; for i := 0 to AList.Count - 1 do begin ptrObjectCurrency := AList[i]; if ptrObjectCurrency.IDCurrency = AIDCurrency then begin Result := ptrObjectCurrency; Break; //// BREAK //// end; end; end; function GetObjectCurrencyByGUIDCurrency(ACatalogID: Integer; AGUID: String; AQSelect: TpFIBQuery): PObjectCurrencyRel; var IDCurrency: integer; begin Result := nil; //*** Найти GUID валюты по ее ID IDCurrency := GetIntFromTableByGUID(tnCurrency, fnID, AGUID, AQSelect); if IDCurrency > 0 then begin Result := GetObjectCurrencyByIntFld(ACatalogID, IDCurrency, fnIDCurrency, AQSelect); if Result <> nil then Result.Data.GUID := AGUID; end; end; function GetObjectCurrencyByGUIDCurrencyFromList(AGUID: String; AList: TList): PObjectCurrencyRel; var i: Integer; ptrObjectCurrency: PObjectCurrencyRel; begin Result := nil; for i := 0 to AList.Count - 1 do begin ptrObjectCurrency := AList[i]; if ptrObjectCurrency.Data.GUID = AGUID then begin Result := ptrObjectCurrency; Break; //// BREAK //// end; end; end; function GetObjectCurrencyByIntFld(ACatalogID, AFldValue: Integer; AFldName: String; AQSelect: TpFIBQuery): PObjectCurrencyRel; var ConditionCatalogID: String; begin Result := nil; ConditionCatalogID := GetZeroConditionAsNull(fnIDCatalog, ACatalogID); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnObjectCurrencyRel, '('+ConditionCatalogID+') and ('+AFldName+' = '''+IntToStr(AFldValue)+''')', nil, fnAll)); if AQSelect.RecordCount > 0 then begin Result := GetObjectCurrencyFromQuery(AQSelect); //*** GUID валюты SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCurrency, fnID+' = '''+IntToStr(Result.IDCurrency)+'''', nil, fnGuid)); if AQSelect.RecordCount > 0 then Result.Data.GUID := AQSelect.Fields[0].AsString; //AQSelect.FN(fnGuid).AsString; end; end; function GetObjectCurrencyByMainFldFromList(AMainValue: Integer; AList: TList): PObjectCurrencyRel; var i: Integer; ptrObjectCurrency: PObjectCurrencyRel; begin Result := nil; for i := 0 to AList.Count - 1 do begin ptrObjectCurrency := AList[i]; if ptrObjectCurrency.Data.Main = AMainValue then begin Result := ptrObjectCurrency; Break; //// BREAK //// end; end; end; function GetObjectCurrencyByMainFld(ACatalogID, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; begin Result := GetObjectCurrencyByIntFld(ACatalogID, AMainValue, fnMain, AQSelect); end; function GetObjectCurrencyFromQuery(AQuery: TpFIBQuery): PObjectCurrencyRel; begin Result := nil; GetZeroMem(Result, SizeOf(TObjectCurrencyRel)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGUID).AsString; Result.IDCatalog := AQuery.FN(fnIDCatalog).AsInteger; Result.IDCurrency := AQuery.FN(fnIDCurrency).AsInteger; //Result.Data.GUID := AQuery.FN(fnGuid).AsString; Result.Data.Kolvo := AQuery.FN(fnKolvo).AsInteger; Result.Data.Ratio := AQuery.FN(fnRatio).AsFloat; Result.Data.Main := AQuery.FN(fnMain).AsInteger; end; function GetPriceAfterChangeNDS(APrice, AOldNDS, ANewNDS: Double): Double; var PriseWithoutNDS: Double; begin Result := APrice; try PriseWithoutNDS := APrice - (APrice * AOldNDS / (100 + AOldNDS)); Result := Round3(PriseWithoutNDS + PriseWithoutNDS * (ANewNDS / 100)); except end; end; function GetPriceAfterChangeCurrency(APrice: Double; AOldCurrency, ANewCurrency: TCurrency; AEpsilon: Integer = 3): Double; begin Result := APrice; try // Tolik -- 12/06/2018 -- для особо "умных", которые любят повыебываться и ставят нули if (ANewCurrency.Ratio <> 0) and (AOldCurrency.Kolvo <> 0) and (ANewCurrency.Kolvo <> 0) then //Result := RoundX(RoundX(APrice, 2) * (RoundX(AOldRatio, 2) / RoundX(ANewRatio, 2)), 2); Result := RoundX(RoundX(APrice, AEpsilon) * ((RoundX(AOldCurrency.Ratio, AEpsilon) / AOldCurrency.Kolvo) / (RoundX(ANewCurrency.Ratio, AEpsilon) / ANewCurrency.Kolvo) ), AEpsilon); except end; end; procedure SaveObjectCurrency(AMakeEdit: TMakeEdit; AObjectCurrency: PObjectCurrencyRel; AQSelect, AQOperat: TpFIBQuery); var FieldNames: TStringList; begin try FieldNames := TStringList.Create; FieldNames.Add(fnIDCatalog); FieldNames.Add(fnIDCurrency); FieldNames.Add(fnKolvo); FieldNames.Add(fnRatio); FieldNames.Add(fnMain); case AMakeEdit of meMake: begin FieldNames.Add(fnGUID); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnObjectCurrencyRel, '', FieldNames, ''), false); AQOperat.ParamByName(fnGUID).AsString := CreateGUID; end; meEdit: SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnObjectCurrencyRel, fnID+' = '''+IntToStr(AObjectCurrency.ID)+'''', FieldNames, ''), false); end; if AObjectCurrency.IDCatalog > 0 then AQOperat.ParamByName(fnIDCatalog).AsInteger := AObjectCurrency.IDCatalog else AQOperat.ParamByName(fnIDCatalog).Value := null; AQOperat.ParamByName(fnIDCurrency).AsInteger := AObjectCurrency.IDCurrency; AQOperat.ParamByName(fnKolvo).AsInteger := AObjectCurrency.Data.Kolvo; AQOperat.ParamByName(fnRatio).AsFloat := AObjectCurrency.Data.Ratio; AQOperat.ParamByName(fnMain).AsInteger := AObjectCurrency.Data.Main; AQOperat.ExecQuery; AQOperat.Close; if AMakeEDit = meMake then AObjectCurrency.ID := GenIDFromTable(AQSelect, gnObjectCurrencyRelID, 0); AQSelect.Close; FreeAndNil(FieldNames); except on E: Exception do AddExceptionToLogEx('SaveObjectCurrency', E.Message); end; end; procedure ConvertSCSNormsToInterfNormsInfo(ASCSNorms: TObject; AInterfNormsInfoList: TList); var Norms: TSCSNorms; SCSNorm: TSCSNorm; i: Integer; ptrNewInterfaceNormInfo: PInterfaceNormInfo; begin Norms := TSCSNorms(ASCSNorms); if Assigned(Norms) and Assigned(AInterfNormsInfoList) then begin for i := 0 to Norms.Count - 1 do begin SCSNorm := Norms[i]; if Assigned(SCSNorm) then begin GetZeroMem(ptrNewInterfaceNormInfo, SizeOf(TInterfaceNormInfo)); ptrNewInterfaceNormInfo.ID := -1; ptrNewInterfaceNormInfo.IDInterface := -1; ptrNewInterfaceNormInfo.InterfaceIsBusy := -1; ptrNewInterfaceNormInfo.GUIDNBNorm := SCSNorm.GuidNB; //ptrNewInterfaceNormInfo.IDNBNorm := SCSNorm.IDNB; ptrNewInterfaceNormInfo.Expense := SCSNorm.Kolvo; AInterfNormsInfoList.Add(ptrNewInterfaceNormInfo); end; end; end; end; function GenCatalogSortIDByIDParent(AIDParent: Integer; AQSelect: TpFIBQuery): Integer; begin Result := 0; SetSQLToFIBQuery(AQSelect, 'select max('+fnSortID+') from '+tnCatalog+' '+ 'where ('+GetZeroConditionAsNull(fnParentID, AIDParent)+')'); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger; Inc(Result); end; function GetCatalogAllChildsIDs(AIDCatalog: Integer; AQSelect: TpFIBQuery): TIntList; procedure Step(AParentID: Integer); var ChildIDs: TIntList; i: Integer; CurrID: Integer; begin //***Отобрать подпапки AQSelect.Close; AQSelect.ParamByName(fnParentID).AsInteger := AParentID; AQSelect.ExecQuery; ChildIDs := TIntList.Create; IntFIBFieldToIntList(ChildIDs, AQSelect, fnID); for i := 0 to ChildIDs.Count - 1 do begin CurrID := ChildIDs[i]; Result.Add(CurrID); Step(CurrID); end; end; begin SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalog, fnParentID+' = :'+fnParentID, nil, fnID), false); Result := TIntList.Create; Step(AIDCatalog); end; function GetCatalogAllComponIDs(AIDCatalog: Integer; AFromChild: Boolean; AQSelect: TpFIBQuery): TIntList; var DirIDs: TIntList; begin Result := nil; DirIDs := nil; if AFromChild then DirIDs := GetCatalogAllChildsIDs(AIDCatalog, AQSelect) else DirIDs := TIntList.Create; DirIDs.Insert(0, AIDCatalog); try Result := GetComponIDsFromCatalogs(DirIDs, AQSelect); finally DirIDs.Free; end; end; function GetCatalogCurrencyByCurrencyID(AIDCatalog, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var IDLevelCatalog: Integer; begin Result := nil; IDLevelCatalog := GetParentCatalogIDByLevel(AIDCatalog, dirCurrencyLevel, AQSelect); if IDLevelCatalog > 0 then Result := GetObjectCurrencyByIDCurrency(IDLevelCatalog, AIDCurrency, AQSelect); if Result = nil then Result := GetDefObjectCurrencyByIDCurrency(AIDCurrency, AQSelect); end; function GetCatalogCurrencyByMainFld(AIDCatalog, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var IDLevelCatalog: Integer; begin Result := nil; IDLevelCatalog := GetParentCatalogIDByLevel(AIDCatalog, dirCurrencyLevel, AQSelect); if IDLevelCatalog > 0 then Result := GetObjectCurrencyByMainFld(IDLevelCatalog, AMainValue, AQSelect); if Result = nil then Result := GetDefObjectCurrencyByMainFld(AMainValue, AQSelect); end; function GetCatalogIDsByLevel(ALevel: Integer; AQSelect: TpFIBQuery): TIntList; var TopCatalogIDs: TIntList; i: integer; procedure LookCatalog(AIDCatalog: Integer; ACatalogLevel: Integer); var ChildCatalogIDs: TIntList; i: Integer; begin if ACatalogLevel = ALevel then Result.Add(AIDCatalog) else //*** Смотреть вглубь if ACatalogLevel < ALevel then begin ChildCatalogIDs := GetCatalogChildsID(AIDCatalog, '', AQSelect); for i := 0 to ChildCatalogIDs.Count - 1 do LookCatalog(ChildCatalogIDs[i], ACatalogLevel+1); FreeAndNil(ChildCatalogIDs); end; end; begin Result := TIntList.Create; //*** Отобрать все верхние папки TopCatalogIDs := GetCatalogChildsID(0, '', AQSelect); for i := 0 to TopCatalogIDs.Count - 1 do LookCatalog(TopCatalogIDs[i], 0); FreeAndNil(TopCatalogIDs); end; function GetCatalogChildsID(AParentID: Integer; ASortFld: String; AQSelect: TpFIBQuery): TIntList; var strQrderBy: String; strFilter: String; begin Result := TIntList.Create; strFilter := '(parent_id = '''+IntToStr(AParentID)+''')'; if AParentID = 0 then strFilter := strFilter + ' or (parent_id is null)'; //strFilter := GetZeroConditionAsNull(fnParentID, AParentID); strQrderBy := ''; if ASortFld <> '' then strQrderBy := 'order by '+ ASortFld; SetSQLToFIBQuery(AQSelect, ' SELECT ID FROM KATALOG ' + ' WHERE '+strFilter+' '+strQrderBy); IntFIBFieldToIntList(Result, AQSelect, fnID); AQSelect.Close; end; function GetParentCatalogIDByLevel(AIDCatalog, ALevel: Integer; AQSelect: TpFIBQuery): Integer; var IDList: TIntList; CurrID: Integer; begin Result := -1; IDList := TIntList.Create; CurrID := AIDCatalog; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalog, fnID+' = :'+fnID, nil, fnParentID), false); while CurrID > 0 do begin IDList.Insert(0, CurrID); AQSelect.Close; AQSelect.ParamByName(fnID).AsInteger := CurrID; AQSelect.ExecQuery; CurrID := 0; if AQSelect.RecordCount > 0 then CurrID := AQSelect.Fields[0].AsInteger; end; if ALevel <= IDList.Count - 1 then Result := IDList[ALevel]; FreeAndNil(IDList); end; function GetParentCatalogPathIDByLevel(AIDCatalog, ALevel: Integer; AQSelect: TpFIBQuery): TIntList; var PathList: TIntList; CurrID: Integer; i: integer; begin Result := TintList.Create; PathList := TIntList.Create; CurrID := AIDCatalog; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalog, fnID+' = :'+fnID, nil, fnParentID), false); while CurrID > 0 do begin PathList.Insert(0, CurrID); AQSelect.Close; AQSelect.Params[0].AsInteger := CurrID; AQSelect.ExecQuery; CurrID := 0; if AQSelect.RecordCount > 0 then CurrID := AQSelect.Fields[0].AsInteger; end; if ALevel <= PathList.Count - 1 then for i := ALevel to PathList.Count - 1 do Result.Add(PathList[i]); PathList.Free; end; function GenComponSortIDByIDCatalog(AIDCatalog: Integer; AQSelect: TpFIBQuery): Integer; begin Result := 0; SetSQLToFIBQuery(AQSelect, 'select max('+tnComponent+'.'+fnSortID+') from '+tnComponent+', '+tnCatalogRelation+' '+ 'where ('+fnIDCatalog+' = '''+IntToStr(AIDCatalog)+''') and ('+fnIDComponent+' = '+tnCatalogRelation+'.'+fnIDComponent+')'); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger; Inc(Result); end; // Tolik 13/08/2019 -- старая закомменчена - см. ниже, а здесь выполнена попытка подрихтовать компоненты, // оторванные от родительских каталогов (так сказать "на лету") function GetComponCatalogOwnerID(AIDComponent: Integer; AQSelect: TpFIBQuery): Integer; var OldSqlText: string; ComponNode, ParentNode: TTreeNode; Nodedat, ParentNodeDat: PObjectData; i: Integer; ParentFound: Boolean; begin Result := 0; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalogRelation, fnIDComponent+' = '''+IntToStr(AIDComponent)+'''', nil, fnIDCatalog)); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger else // Tolik 13/08/2019 -- а вот здесь, если компонент "неправильный", попробуем его порихтовать // (для этого нужно прописать родительский каталог) begin if (AQSelect.Owner = TF_Main(F_NormBase).dm) then begin ComponNode := Nil; for i := 0 to TF_Main(F_NormBase).Tree_Catalog.Items.Count - 1 do begin ComponNode := TF_Main(F_NormBase).Tree_Catalog.Items[i]; NodeDat := ComponNode.Data; if ((NodeDat <> nil) and (NodeDat.ObjectID = AIDComponent)) then begin Break; //// BREAK //// end else ComponNode := nil; end; ParentNode := nil; if ComponNode <> nil then begin if NodeDat.ItemType in [itComponCon, itComponLine] then begin ParentFound := False; ParentNode := ComponNode.Parent; repeat if ParentNode <> nil then begin ParentNodeDat := ParentNode.Data; if (ParentNodeDat.ItemType = itDir) then //if (ParentNodeDat.ComponKind = ckNone) then ParentFound := True else ParentNode := ParentNode.Parent; end else exit; until ParentFound; end; end; if ParentNode <> nil then begin //*TF_Main(F_NormBase).MoveDir(ComponNode, ParentNode); //AppendToCatalRel(PObjectData(ATrgNode.Data).ObjectID, ID_SavedCompon); TF_Main(F_NormBase).AppendToCatalRel(PObjectData(ParentNode.Data).ObjectID, PObjectData(ComponNode.data).ObjectID); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalogRelation, fnIDComponent+' = '''+IntToStr(AIDComponent)+'''', nil, fnIDCatalog)); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger; end; end; end; end; { function GetComponCatalogOwnerID(AIDComponent: Integer; AQSelect: TpFIBQuery): Integer; begin Result := 0; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalogRelation, fnIDComponent+' = '''+IntToStr(AIDComponent)+'''', nil, fnIDCatalog)); if AQSelect.RecordCount > 0 then Result := AQSelect.Fields[0].AsInteger; end; } function GetComponCatalogOwnerIDByLevel(AIDComponent, ALevel: Integer; AQSelect: TpFIBQuery): Integer; var IDCatalogOwner: Integer; begin Result := 0; IDCatalogOwner := GetComponCatalogOwnerID(AIDComponent, AQSelect); if IDCatalogOwner > 0 then Result := GetParentCatalogIDByLevel(IDCatalogOwner, ALevel, AQSelect); end; function GetComponCatalogOwnerPathIDByLevel(AIDComponent, ALevel: Integer; AQSelect: TpFIBQuery): TintList; var IDCatalogOwner: Integer; begin Result := nil; IDCatalogOwner := GetComponCatalogOwnerID(AIDComponent, AQSelect); if IDCatalogOwner > 0 then Result := GetParentCatalogPathIDByLevel(IDCatalogOwner, ALevel, AQSelect); end; function GetComponCurrencyByCurrencyID(AIDComponent, AIDCurrency: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var IDCatalogOwner: Integer; begin Result := nil; IDCatalogOwner := GetComponCatalogOwnerID(AIDComponent, AQSelect); if IDCatalogOwner > 0 then Result := GetCatalogCurrencyByCurrencyID(IDCatalogOwner, AIDCurrency, AQSelect); end; function GetComponCurrencyByMainFld(AIDComponent, AMainValue: Integer; AQSelect: TpFIBQuery): PObjectCurrencyRel; var IDCatalogOwner: Integer; begin Result := nil; IDCatalogOwner := GetComponCatalogOwnerID(AIDComponent, AQSelect); if IDCatalogOwner > 0 then Result := GetCatalogCurrencyByMainFld(IDCatalogOwner, AMainValue, AQSelect); end; function GetComponIDsFromCatalogs(ACatalogIDs: TIntList; AQSelect: TpFIBQuery): TIntList; var i: Integer; begin Result := TIntList.Create; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalogRelation, fnIDCatalog+'= :'+fnIDCatalog, nil, fnIDComponent), false); for i := 0 to ACatalogIDs.Count - 1 do begin AQSelect.Close; AQSelect.ParamByName(fnIDCatalog).AsInteger := ACatalogIDs[i]; AQSelect.ExecQuery; IntFIBFieldToIntList(Result, AQSelect, fnIDComponent); end; end; procedure GetComponsResourcesID(AIDComponents: TIntList; ADestNormResRelID, ADestResourcesID: TIntList; AQSelect: TpFIBQuery); var i: Integer; begin //*** Отобрать связи с ресурсами? и ресурсы SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnNormResourceRel, '('+fnIDComponent+' = :'+fnIDComponent+') and ('+fnTableKind+' = '''+IntToStr(ctkComponent)+''')', nil, fnID+', '+fnIDResource), false); for i := 0 to AIDComponents.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := AIDComponents[i]; AQSelect.ExecQuery; while Not AQSelect.Eof do begin ADestNormResRelID.Add(AQSelect.Fields[0].AsInteger); ADestResourcesID.Add(AQSelect.Fields[1].AsInteger); AQSelect.Next; end; end; end; procedure GetComponsNormsID(AIDComponents: TIntList; ADestNormsID: TIntList; AQSelect: TpFIBQuery); var i: Integer; begin //*** Отобрать связи с нормами SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnNorms, '('+fnIDComponent+' = :'+fnIDComponent+') and ('+fnTableKind+' = '''+IntToStr(ctkComponent)+''')', nil, fnID), false); for i := 0 to AIDComponents.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := AIDComponents[i]; AQSelect.ExecQuery; while Not AQSelect.Eof do begin ADestNormsID.Add(AQSelect.Fields[0].AsInteger); AQSelect.Next; end; end; end; function GetComponentTypeFromQuery(AQuery: TpFIBQuery): TComponentType; begin ZeroMemory(@Result, SizeOf(TComponentType)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGuid).AsString; Result.NAME := AQuery.FN(fnName).AsString; Result.NamePlural := AQuery.FN(fnNamePlural).AsString; Result.SysName := AQuery.FN(fnSysName).AsString; Result.MarkMask := AQuery.FN(fnMarkMask).AsString; Result.PortKind := AQuery.FN(fnPortKind).AsInteger; Result.ActiveState := AQuery.FN(fnActiveState).AsInteger; Result.IsLine := AQuery.FN(fnIsLine).AsInteger; Result.IDDesignIcon := AQuery.FN(fnIDDesignIcon).AsInteger; Result.IsStandart := AQuery.FN(fnisStandart).AsInteger; Result.CoordZ := AQuery.FN(fnCoordZ).AsFloat; Result.IDComponTemplate := AQuery.FN(fnIDComponTemplate).AsInteger; Result.CanUseAsPoint := AQuery.FN(fnCanUseAsPoint).AsInteger; end; function GetPropertyDataFromQuery(AQuery: TpFIBQuery): TPropertyData; begin ZeroMemory(@Result, SizeOF(TPropertyData)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGUID).AsString; Result.IDDataType := AQuery.FN(fnIDDataType).AsInteger; Result.Name := AQuery.FN(fnName).AsString; Result.SysName := AQuery.FN(fnSysName).AsString; Result.Izm := AQuery.FN(fnIzm).AsString; Result.ValueReq := AQuery.FN(fnValueReq).AsInteger; Result.MinValue := AQuery.FN(fnMinValue).AsFloat; Result.MaxValue := AQuery.FN(fnMaxValue).AsFloat; Result.DefValue := AQuery.FN(fnDefValue).AsString; Result.Description := AQuery.FN(fnDescription).AsString; Result.IsStandart := AQuery.FN(fnIsStandart).AsInteger; Result.SortID := AQuery.FN(fnSortID).AsInteger; Result.ISProject := AQuery.FN(fnISProject).AsInteger; Result.ISFolder := AQuery.FN(fnISFolder).AsInteger; Result.ISList := AQuery.FN(fnISList).AsInteger; Result.ISRoom := AQuery.FN(fnISRoom).AsInteger; Result.ISSCSLine := AQuery.FN(fnISSCSLine).AsInteger; Result.ISSCSConnector := AQuery.FN(fnISSCSConnector).AsInteger; Result.ISComponLine := AQuery.FN(fnISComponLine).AsInteger; Result.ISComponConn := AQuery.FN(fnISComponConn).AsInteger; Result.IsForWholeComponent := AQuery.FN(fnIsForWholeComponent).AsInteger; Result.IsValueRelToObj := AQuery.FN(fnIsValueRelToObj).AsInteger; end; function GetPropValRelDataFromQuery(AQuery: TpFIBQuery): TPropValRelData; begin ZeroMemory(@Result, SizeOf(TPropValRelData)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGUID).AsString; Result.IDProperty := AQuery.FN(fnIDProperty).AsInteger; Result.PValue := AQuery.FN(fnPValue).AsString; Result.MinValue := AQuery.FN(fnMinValue).AsString; Result.MaxValue := AQuery.FN(fnMaxValue).AsString; end; function GetPropValNormResData(AQuery: TpFIBQuery): TPropValNormResData; begin ZeroMemory(@Result, SizeOf(TPropValNormResData)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGUID).AsString; Result.IDPropValRel := AQuery.FN(fnIDPropValRel).AsInteger; Result.IDNBComponent := AQuery.FN(fnIDNBComponent).AsInteger; Result.IDNBRes := AQuery.FN(fnIDNBRES).AsInteger; Result.IDNBNorm := AQuery.FN(fnIDNBNorm).AsInteger; Result.Kolvo := AQuery.FN(fnKolvo).AsFloat; Result.ExpenseForLength := AQuery.FN(fnExpenseForLength).AsFloat; Result.CountForPoint := AQuery.FN(fnCountForPoint).AsFloat; Result.StepOfPoint := AQuery.FN(fnStepOfPoint).AsFloat; end; function GetSuppliesKindFromQuery(AQuery: TpFIBQuery): TSuppliesKind; begin ZeroMemory(@Result, SizeOf(TSuppliesKind)); Result.ID := AQuery.FN(fnID).AsInteger; Result.GUID := AQuery.FN(fnGUID).AsString; Result.Name := AQuery.FN(fnName).AsString; Result.NameTradUOM := AQuery.FN(fnNameTradUOM).AsString; Result.Izm := AQuery.FN(fnIzm).AsString; Result.IzmTradUOM := AQuery.FN(fnIzmTradUOM).AsString; Result.UnitKolvo := AQuery.FN(fnUnitKolvo).AsFloat; Result.UnitKolvoTradUOM := AQuery.FN(fnUnitKolvoTradUOM).AsFloat; end; procedure DefineSuppliesKindWorkValuesToFields(var ASuppliesKind: TSuppliesKind; AUOM: Integer); begin if CheckIsTradUOM(AUOM) then begin ASuppliesKind.Name := ASuppliesKind.NameTradUOM; ASuppliesKind.Izm := ASuppliesKind.IzmTradUOM; ASuppliesKind.UnitKolvo := ASuppliesKind.UnitKolvoTradUOM; end; end; procedure ClearSpareComponPropertues(AQSelect, AQOperat: TpFIBQuery); var IDCompons: TIntList; IDProperties: TIntList; IDPropertyOfProperties: TIntList; i, j, k: Integer; CurrComponID: Integer; PropertyFieldNames: TStringList; SCSComponent: TSCSComponent; WasDelete: Boolean; begin IDCompons := TIntList.Create; IDProperties := TIntList.Create; IDPropertyOfProperties := TIntList.Create; PropertyFieldNames := TStringList.Create; PropertyFieldNames.Add(fnID); PropertyFieldNames.Add(fnIDProperty); try SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponent, '', nil, fnID)); IntFIBFieldToIntList(IDCompons, AQSelect, fnID); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCompPropRelation, fnIDComponent+' = :'+fnIDComponent, PropertyFieldNames, ''), false); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtDelete, tnCompPropRelation, fnID+' = :'+fnID, nil, ''), false); for i := 0 to IDCompons.Count - 1 do begin CurrComponID := IDCompons[i]; //*** Отобрать свойсва компоненты AQSelect.Close; AQSelect.ParamByName(fnIDComponent).AsInteger := CurrComponID; AQSelect.ExecQuery; IDProperties.Clear; IDPropertyOfProperties.Clear; while Not AQSelect.Eof do begin IDProperties.Add(AQSelect.FN(fnID).AsInteger); IDPropertyOfProperties.Add(AQSelect.FN(fnIDProperty).AsInteger); AQSelect.Next; end; j := 0; while j <= IDPropertyOfProperties.Count - 1 do begin k := 0; WasDelete := false; while k <= IDPropertyOfProperties.Count - 1 do begin if (j <> k) and (IDPropertyOfProperties[j] = IDPropertyOfProperties[k]) then begin AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := IDProperties[k]; AQOperat.ExecQuery; IDPropertyOfProperties.Delete(k); IDProperties.Delete(k); WasDelete := true; end else Inc(k); end; if Not WasDelete then inc(j); end; end; finally IDCompons.Free; IDProperties.Free; IDPropertyOfProperties.Free; PropertyFieldNames.Free; end; end; procedure DefineComponKolComplects(AQSelect, AQOperat: TpFIBQuery); var IDs: TIntList; CurrComponID: Integer; CurrCompRelID: Integer; KolComplects: TIntList; RealKolComplects: TIntList; SelectFields: TStringList; i, j: Integer; CurrRealKolComplect: Integer; IDIndex: Integer; StartIndex: integer; IDComponsWithComplects: TIntList; // Список компонент, в которых есть комплектующие IDCompRelWithComplects: TIntList; // Список комплектующих, у которых есть подкомплектующие RealComplCount: Integer; FindedForI: Boolean; SavedQOperatOptions: TpFIBQueryOptions; //Tolik 28/08/2019 -- //CurrTick, OldTick: Cardinal; CurrTick, OldTick: DWord; // begin OldTick := GetTickCount; try IDs := TIntList.Create; KolComplects := TIntList.Create; RealKolComplects := TIntList.Create; SelectFields := TStringList.Create; try //*** Найти ID всех компонент SelectFields.Add(fnID); SelectFields.Add(fnKolComplect); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponent, '', SelectFields, ''), false); AQSelect.SQL.Text := AQSelect.SQL.Text + 'order by '+fnID; AQSelect.ExecQuery; while Not AQSelect.Eof do begin // ID IDs.Add(AQSelect.FIelds[0].AsInteger); //ComponIDs.Add(AQSelect.FN(fnID).AsInteger); // KolComplect KolComplects.Add(AQSelect.FIelds[1].AsInteger); //KolComplects.Add(AQSelect.FN(fnKolComplect).AsInteger); RealKolComplects.Add(0); AQSelect.Next; end; ////*** Определить реальные количества комплектующих // SetSQLToFIBQuery(AQSelect, 'select count(id) from component_relation '+ // 'where ('+fnIDComponent+' = :'+fnIDComponent+') and '+ // '('+fnIDParentCompRel+' is null) and '+ // '('+fnConnectType+' = '''+IntToStr(cntComplect)+''') ', false); // for i := 0 to IDs.Count - 1 do // begin // AQSelect.Close; // AQSelect.Params[0].AsInteger := IDs[i]; //AQSelect.ParamsByName(fnIDComponent).AsInteger := ComponIDs[i]; // AQSelect.ExecQuery; // RealKolComplects.Add(AQSelect.Fields[0].AsInteger); // //RealKolComplects.Add(AQSelect.FN(fnCount).AsInteger); // end; //*** Определить реальные количества комплектующих IDComponsWithComplects := TIntList.Create; try //*** Отобрать связи комплектующих SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentRelation, '('+fnIDParentCompRel+' is null) and ('+fnConnectType+' = '''+IntToStr(cntComplect)+''')', nil, fnIDComponent), false); AQSelect.SQL.Text := AQSelect.SQL.Text + 'order by '+ fnIDComponent; AQSelect.ExecQuery; while Not AQSelect.Eof do begin IDComponsWithComplects.Add(AQSelect.Fields[0].AsInteger); AQSelect.Next; end; //*** Поиск количества для каждой компоненты из списка IDs for i := IDs.Count - 1 downto 0 do begin CurrComponID := Integer(IDs.List.List^[i]); //IDs[i]; RealComplCount := 0; IDIndex := GetValueIndexFromSortedIntList(CurrComponID, IDComponsWithComplects); if IDIndex <> -1 then begin StartIndex := IDIndex; // данный индекс ID-ка находится вначале, а нам нужно с конца, тогда ищем индекс вперед for j := StartIndex to IDComponsWithComplects.Count - 1 do begin if Integer(IDComponsWithComplects.List.List^[j]) = CurrComponID then StartIndex := j else Break; //// BREAK //// end; //03.03.2009 j := IDComponsWithComplects.Count - 1; j := StartIndex; FindedForI := false; while j >= 0 do begin if Integer(IDComponsWithComplects.List.List^[j]) = CurrComponID then begin FindedForI := true; RealComplCount := RealComplCount + 1; IDComponsWithComplects.Delete(j); end else if FindedForI then Break; //// BREAK //// j := j - 1; end; end; //03.03.2009 RealKolComplects.Insert(0, RealComplCount); Integer(RealKolComplects.List.List^[i]) := RealComplCount; //RealKolComplects[i] := RealComplCount; end; finally FreeAndNil(IDComponsWithComplects); end; //*** пологнать не соответствующие значения SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnComponent, fnID+' = :'+fnID, nil, fnKolComplect), false); AQOperat.Transaction.StartTransaction; for i := 0 to IDs.Count - 1 do begin CurrRealKolComplect := Integer(RealKolComplects.List.List^[i]); //RealKolComplects[i]; if Integer(KolComplects.List.List^[i]) <> CurrRealKolComplect then begin AQOperat.Close; // KolComplect AQOperat.Params[0].AsInteger := CurrRealKolComplect; //AQOperat.ParamByName(fnKolComplect).AsInteger := CurrRealKolComplect; // ID AQOperat.Params[1].AsInteger := Integer(IDs.List.List^[i]); //IDs[i]; //AQOperat.ParamByName(fnID).AsInteger := ComponIDs[i]; AQOperat.ExecQuery; end; end; AQOperat.Transaction.Commit; AQOperat.Close; finally AQOperat.Options := SavedQOperatOptions; end; // //*** Тоже самое для подкомплектующих // IDs.Clear; KolComplects.Clear; RealKolComplects.Clear; SelectFields.Clear; //*** Найти ID всех связей компонент SelectFields.Add(fnID); SelectFields.Add(fnKolSubComplect); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentRelation, '', SelectFields, '')); while Not AQSelect.Eof do begin // ID IDs.Add(AQSelect.FIelds[0].AsInteger); // KolSubComplect KolComplects.Add(AQSelect.FIelds[1].AsInteger); //RealKolComplects.Add(0); AQSelect.Next; end; //*** Определить реальные количества подкомплектующих SetSQLToFIBQuery(AQSelect, 'select count(id) from component_relation '+ 'where ('+fnIDParentCompRel+' = :'+fnIDParentCompRel+')', false); for i := 0 to IDs.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := Integer(IDs.List.List^[i]); //IDs[i]; //AQSelect.ParamsByName(fnIDComponent).AsInteger := ComponIDs[i]; AQSelect.ExecQuery; RealKolComplects.Add(AQSelect.Fields[0].AsInteger); //RealKolComplects.Add(AQSelect.FN(fnCount).AsInteger); end; {//03.03.2009 //*** Определить реальные количества подкомплектующих IDCompRelWithComplects := TIntList.Create; SetSQLToFIBQuery(AQSelect, 'select '+fnIDParentCompRel+' from component_relation '+ 'where Not('+fnIDParentCompRel+' is null) order by '+fnIDParentCompRel, false); while Not AQSelect.Eof do begin IDCompRelWithComplects.Add(AQSelect.Fields[0].AsInteger); AQSelect.Next; end; for i := IDs.Count - 1 downto 0 do begin CurrCompRelID := Integer(IDs.List.List^[i]); //IDs[i]; RealComplCount := 0; IDIndex := GetValueIndexFromSortedIntList(CurrCompRelID, IDCompRelWithComplects); if IDIndex <> -1 then begin StartIndex := IDIndex; // данный индекс ID-ка находится вначале, а нам нужно с конца, тогда ищем индекс вперед for j := StartIndex to IDCompRelWithComplects.Count - 1 do begin if Integer(IDCompRelWithComplects.List.List^[j]) = CurrCompRelID then StartIndex := j else Break; //// BREAK //// end; j := StartIndex; FindedForI := false; while j >= 0 do begin if Integer(IDCompRelWithComplects.List.List^[j]) = CurrCompRelID then begin FindedForI := true; Inc(RealComplCount); IDCompRelWithComplects.Delete(j); end else if FindedForI then Break; //// BREAK //// Dec(j); end; end; Integer(RealKolComplects.List.List^[i]) := RealComplCount; end; } //*** пологнать не соответствующие значения SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnComponentRelation, fnID+' = :'+fnID, nil, fnKolSubComplect), false); AQOperat.Transaction.StartTransaction; for i := 0 to IDs.Count - 1 do begin CurrRealKolComplect := Integer(RealKolComplects.List.List^[i]); //RealKolComplects[i]; if Integer(KolComplects.List.List^[i]) <> CurrRealKolComplect then begin AQOperat.Close; // KolComplect AQOperat.Params[0].AsInteger := CurrRealKolComplect; //AQOperat.ParamByName(fnKolComplect).AsInteger := CurrRealKolComplect; // ID AQOperat.Params[1].AsInteger := Integer(IDs.List.List^[i]); //IDs[i]; //AQOperat.ParamByName(fnID).AsInteger := ComponIDs[i]; AQOperat.ExecQuery; end; end; AQOperat.Transaction.Commit; AQOperat.Close; finally AQOperat.Options := SavedQOperatOptions; end; finally FreeAndNil(IDs); FreeAndNil(KolComplects); FreeAndNil(RealKolComplects); FreeAndNil(SelectFields); end; except on E: Exception do AddExceptionToLogEx('DefineComponKolComplects', E.Message); end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; procedure DefineCatalogKolItemsCompons(AQSelect, AQOperat: TpFIBQuery); var CatalogIDs: TIntList; ItemCounts: TIntList; KolCompons: TIntList; RealItemCounts: TIntList; RealKolCompons: TIntList; SelectCatalogFields: TStringList; i: Integer; CurrRealItemCount: Integer; CurrRealKolCompon: Integer; SavedQOperatOptions: TpFIBQueryOptions; begin try CatalogIDs := TIntList.Create; ItemCounts := TIntList.Create; KolCompons := TIntList.Create; RealItemCounts := TIntList.Create; RealKolCompons := TIntList.Create; SelectCatalogFields := TStringList.Create; try //*** Отобрать Id и количества для всех папок SelectCatalogFields.Add(fnID); SelectCatalogFields.Add(fnItemsCount); SelectCatalogFields.Add(fnKolCompon); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCatalog, '', SelectCatalogFields, '')); while Not AQSelect.Eof do begin // ID CatalogIDs.Add(AQSelect.Fields[0].AsInteger); //CatalogIDs.Add(AQSelect.FN(fnID).AsInteger); // ItemsCount ItemCounts.Add(AQSelect.Fields[1].AsInteger); //ItemCounts.Add(AQSelect.FN(fnItemsCount).AsInteger); // KolCompon KolCompons.Add(AQSelect.Fields[2].AsInteger); //KolCompons.Add(AQSelect.FN(fnKolCompon).AsInteger); AQSelect.Next; end; //**** Определить реальные количества //*** Определить реальное кол-во подпапок в папках SetSQLToFIBQuery(AQSelect, 'select count(id) from '+tnCatalog+' '+ 'where '+fnParentID+' = :'+fnID, false); for i := 0 to CatalogIDs.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := CatalogIDs[i]; //AQSelect.ParamByName(fnID).AsInteger := CatalogIDs[i]; AQSelect.ExecQuery; RealItemCounts.Add(AQSelect.Fields[0].AsInteger); //RealItemCounts.Add(AQSelect.FN(fnCount).AsInteger); end; //*** Определить реальное кол-во компонент в папках SetSQLToFIBQuery(AQSelect, 'select count(id) from '+tnCatalogRelation+' '+ 'where '+fnIDCatalog+' = :'+fnIDCatalog, false); for i := 0 to CatalogIDs.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := CatalogIDs[i]; //AQSelect.ParamByName(fnIDCatalog).AsInteger := CatalogIDs[i]; AQSelect.ExecQuery; RealKolCompons.Add(AQSelect.Fields[0].AsInteger); //RealKolCompons.Add(AQSelect.FN(fnCount).AsInteger); end; //*** Коррекция значений //*** Количество подпапок в папках SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCatalog, fnID+' = :'+fnID, nil, fnItemsCount), false); AQOperat.Transaction.StartTransaction; for i := 0 to CatalogIDs.Count - 1 do begin CurrRealItemCount := RealItemCounts[i]; if ItemCounts[i] <> CurrRealItemCount then begin AQOperat.Close; // ItemsCount AQOperat.Params[0].AsInteger := CurrRealItemCount; //AQOperat.ParamByName(fnItemsCount).AsInteger := CurrRealItemCount; // ID AQOperat.Params[1].AsInteger := CatalogIDs[i]; //AQOperat.ParamByName(fnID).AsInteger := CatalogIDs[i]; AQOperat.ExecQuery; end; end; AQOperat.Transaction.Commit; AQOperat.Close; finally AQOperat.Options := SavedQOperatOptions; end; //*** Количество компонент в папках SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCatalog, fnID+' = :'+fnID, nil, fnKolCompon), false); AQOperat.Transaction.StartTransaction; for i := 0 to CatalogIDs.Count - 1 do begin CurrRealKolCompon := RealKolCompons[i]; if KolCompons[i] <> CurrRealKolCompon then begin AQOperat.Close; // KolCompon AQOperat.Params[0].AsInteger := CurrRealKolCompon; //AQOperat.ParamByName(fnKolCompon).AsInteger := CurrRealKolCompon; // ID AQOperat.Params[1].AsInteger := CatalogIDs[i]; //AQOperat.ParamByName(fnID).AsInteger := CatalogIDs[i]; AQOperat.ExecQuery; end; end; AQOperat.Transaction.Commit; AQOperat.Close; finally AQOperat.Options := SavedQOperatOptions; end; finally FreeAndNil(CatalogIDs); FreeAndNil(ItemCounts); FreeAndNil(KolCompons); FreeAndNil(RealItemCounts); FreeAndNil(RealKolCompons); FreeAndNil(SelectCatalogFields); end; except on E: Exception do AddExceptionToLogEx('DefineCatalogKolItemsCompons', E.Message); end; end; procedure DefineDirTypeContentCount(AQSelect, AQOperat: TpFIBQuery; ADirTypeIDs, ADirTypeRelIDs: TIntList); var DirTypeIDsToDefineContents: TIntList; begin try DirTypeIDsToDefineContents := TIntList.Create; FreeAndNil(DirTypeIDsToDefineContents); except on E: Exception do AddExceptionToLogEx('', E.Message); end; end; procedure DefineDirTypeChildContentCount(AQSelect, AQOperat: TpFIBQuery); var DirTypeIDs: TIntList; DirTypeChildCounts: TIntList; DirTypeContentCounts: TIntList; RealDirTypeChildCounts: TIntList; RealDirTypeContentCounts: TIntList; CurrRealDirTypeChildCount: Integer; CurrRealDirTypeContentCount: Integer; FieldNames: TStringList; //SavedQOperatOptions: TpFIBQueryOptions; //OldTick, CurrTick: Cardinal; i: Integer; begin try DirTypeIDs := TIntList.Create; DirTypeChildCounts := TIntList.Create; DirTypeContentCounts := TIntList.Create; RealDirTypeChildCounts := TIntList.Create; RealDirTypeContentCounts := TIntList.Create; FieldNames := TStringList.Create; //OldTick := GetTickCount; //*** Найти все количества всех папок SetSQLToFIBQuery(AQSelect, 'select '+fnID+', '+fnItemsCount+', '+fnContentKolvo+' from '+tnDirectoryType); AQSelect.ExecQuery; while Not AQSelect.Eof do begin DirTypeIDs.Add(AQSelect.Fields[0].AsInteger); DirTypeChildCounts.Add(AQSelect.Fields[1].AsInteger); DirTypeContentCounts.Add(AQSelect.Fields[2].AsInteger); AQSelect.Next; end; //*** Найти реальное кол-во подпапок SetSQLToFIBQuery(AQSelect, 'select count(id) from '+tnDirectoryType+' '+ 'where '+fnParentID+' = :'+fnID, false); for i := 0 to DirTypeIDs.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := DirTypeIDs[i]; AQSelect.ExecQuery; RealDirTypeChildCounts.Add(AQSelect.Fields[0].AsInteger); end; //*** Найти количества элементов для папок SetSQLToFIBQuery(AQSelect, 'select count(id) from '+tnDirectoryTypeRel+' '+ 'where '+fnIDDirectoryType+' = :'+fnIDDirectoryType, false); for i := 0 to DirTypeIDs.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := DirTypeIDs[i]; AQSelect.ExecQuery; RealDirTypeContentCounts.Add(AQSelect.Fields[0].AsInteger); end; //*** Запрос на обновление FieldNames.Add(fnItemsCount); FieldNames.Add(fnContentKolvo); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnDirectoryType, fnID+' = :'+fnID, FieldNames, ''), false); for i := 0 to DirTypeIDs.Count - 1 do begin CurrRealDirTypeChildCount := RealDirTypeChildCounts[i]; CurrRealDirTypeContentCount := RealDirTypeContentCounts[i]; if (DirTypeChildCounts[i] <> CurrRealDirTypeChildCount) or (DirTypeContentCounts[i] <> CurrRealDirTypeContentCount) then begin AQOperat.Close; // ChildItemsCount AQOperat.Params[0].AsInteger := CurrRealDirTypeChildCount; // ContentCount AQOperat.Params[1].AsInteger := CurrRealDirTypeContentCount; // ID AQOperat.Params[2].AsInteger := DirTypeIDs[i]; AQOperat.ExecQuery; end; end; //*** Освободить все нах... FreeAndNil(FieldNames); FreeAndNil(RealDirTypeChildCounts); FreeAndNil(RealDirTypeContentCounts); FreeAndNil(DirTypeContentCounts); FreeAndNil(DirTypeChildCounts); FreeAndNil(DirTypeIDs); except on E: Exception do AddExceptionToLogEx('DefineDirTypeChildContentCount', E.Message); end; end; procedure DefineIndividualComplectsByEmptyIDTopCompon(AQSelect, AQOperat: TpFIBQuery); var // i-е елементы взаемосвязаны NoDefinedComplects: TList; ListOfComplectIOfIRels: TObjectList; // список списков(TList) о инфе связанных интерфейсов на компоновке ListOfListNewID: TObjectList; // список списков(TIntList) новых id-в для NoDefinedComplects[i] InterfRelIDsToNoBusy: TIntList; // ID Интерфейсов для сброса флага IsBusy AllCrossConnections: TObjectList; ComponCrossConnections: TObjectList; ComplectIOfIRels: TList; ListNewID: TintList; ptrComplect: PComplect; ptrIOfIRel: PIOfIRel; CrossConnection: TSCSCrossConnection; i, j, k: Integer; SavedQOperatOptions: TpFIBQueryOptions; ChildComplectPath: TList; FieldNames: TStringList; MaxIDCompRel: Integer; LastGenIDCompRel: Integer; // Вернет кол-во подкомплектующих function GetKolSubComplect(AComplect: PComplect): Integer; var i: integer; ptrComplect: PComplect; begin Result := 0; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; if ptrComplect <> AComplect then if ptrComplect.ID_Component = AComplect.ID_Child then Inc(Result); end; end; procedure LoadCrossConnectionsToListByIDTopComponent(AIDTopComponent: Integer; AList: TObjectList); var i: Integer; CrossConnection: TSCSCrossConnection; begin AList.Clear; for i := 0 to AllCrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(AllCrossConnections[i]); if CrossConnection.IDComponent = AIDTopComponent then AList.Add(CrossConnection); end; end; (* procedure DefineIndividualComplectsForParents(AComplect: PComplect; ACrossConnections: TObjectList; ACrossSideType, ACrossConnectionIndex: PInteger; ACompRelPath: TIntList; ATopComponID, AIDParentCompRel, AStepIndex: Integer); var i, j, k: Integer; ptrComplect: PComplect; KolSubComplect: Integer; IndexOfComplect: Integer; ListNewID: TIntList; CrossConnection: TSCSCrossConnection; FindedIDCompRel: Boolean; SavedLastGenIDCompRel: Integer; CompRelPath: TIntList; CompRelPathLastIndex: Integer; IsActualPath: Boolean; CrossSideType: Integer; CrossConnectionIndex: Integer; PathList: TIntList; IndexID: Integer; begin CompRelPath := nil; if ACompRelPath <> nil then CompRelPath := ACompRelPath else CompRelPath := TIntList.Create; CompRelPath.Insert(0, AComplect.ID); for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; if ptrComplect.ID_Component = AComplect.ID_Child then begin ListNewID := nil; ListNewID := TIntList(ListOfListNewID[i]); AQOperat.Close; AQOperat.ParamByName(fnIDComponent).AsInteger := ptrComplect.ID_Component; AQOperat.ParamByName(fnIDChild).AsInteger := ptrComplect.ID_Child; AQOperat.ParamByName(fnIDTopCompon).AsInteger := ATopComponID; AQOperat.ParamByName(fnIDParentCompRel).AsInteger := AIDParentCompRel; AQOperat.ParamByName(fnKolSubComplect).AsInteger := ptrComplect.KolSubComplect; AQOperat.ParamByName(fnKolvo).AsInteger := ptrComplect.Kolvo; AQOperat.ParamByName(fnConnectType).AsInteger := ptrComplect.ConnectType; AQOperat.ParamByName(fnSortID).AsInteger := ptrComplect.SortID; AQOperat.ExecQuery; //*** Определить новый ID Inc(LastGenIDCompRel); if ListNewID <> nil then ListNewID.Add(LastGenIDCompRel); SavedLastGenIDCompRel := LastGenIDCompRel; CrossSideType := -1; CrossConnectionIndex := -1; //*** Тело рекурсии DefineIndividualComplectsForParents(ptrComplect, ACrossConnections, @CrossSideType, @CrossConnectionIndex, CompRelPath, ATopComponID, LastGenIDCompRel, AStepIndex+1); //*** Смотрим, что удалось найти при просмотре вглубь // //*** Если не найшли конечное подключение, то попытаться определить его if (CrossSideType = -1) and (CrossConnectionIndex = -1) then begin for j := 0 to ACrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(ACrossConnections[j]); if CrossConnection.IDCompRelFrom = ptrComplect.ID then begin CrossConnection.IDCompRelFrom := SavedLastGenIDCompRel; FindedIDCompRel := true; if ACrossSideType <> nil then ACrossSideType^ := ptFrom; if ACrossConnectionIndex <> nil then ACrossConnectionIndex^ := j; end else if CrossConnection.IDCompRelTo = ptrComplect.ID then begin CrossConnection.IDCompRelTo := SavedLastGenIDCompRel; FindedIDCompRel := true; if ACrossSideType <> nil then ACrossSideType^ := ptTo; if ACrossConnectionIndex <> nil then ACrossConnectionIndex^ := j; end; if FindedIDCompRel then Break; //// BREAK //// end end else //*** Если нашли, то сравнить ID пути с ptrComplect.ID по индексу текущего шага рекурсии if (CrossSideType <> -1) and (CrossConnectionIndex <> -1) then begin CrossConnection := nil; if CrossConnectionIndex <= (ACrossConnections.Count-1) then CrossConnection := TSCSCrossConnection(ACrossConnections[CrossConnectionIndex]); if CrossConnection <> nil then begin //*** Определяем тип стороны пути PathList := nil; if CrossSideType = ptFrom then PathList := CrossConnection.CompRelFromPath else if CrossSideType = ptTo then PathList := CrossConnection.CompRelToPath; //*** ID c последнего индекса пути должен совпадать с верхним CompRel.ID if (PathList <> nil) and (PathList.Count > 0) {and (PathList[PathList.Count-1] = ATopCompRelID)} then begin IsActualPath := true; //*** Проверить, правильный ли путь CompRelPathLastIndex := CompRelPath.Count - 1; for j := PathList.Count-1 downto 1 do begin if PathList[j] <> CompRelPath[CompRelPathLastIndex] then begin IsActualPath := false; Break; //// BREAK //// end; Dec(CompRelPathLastIndex); if CompRelPathLastIndex = -1 then Break; //// BREAK //// end; if IsActualPath then begin // Определяем по индексу текущего шага рекурсии IndexID := -1; if AStepIndex <= (PathList.Count-1) then //*** учитываем то, что путь указывается снизу вверх, а рекурсия наооботот - сверху вниз IndexID := (PathList.Count-1) - AStepIndex; if IndexID <> -1 then begin //*** Индекс смешаем на 1 на убывание потому, что AComplect в самом верхнем шаге рекурсии // включен а последний индекс пути IndexID := IndexID - 1; if PathList[IndexID] = ptrComplect.ID then PathList[IndexID] := SavedLastGenIDCompRel else IsActualPath := false; end; end; //*** Если пути не совпадают, значит этот путь здесь нельзя расматривать // и конечные ID возвращаем на место if Not IsActualPath then begin CrossConnection.IDCompRelFrom := CrossConnection.OldIDCompRelFrom; CrossConnection.IDCompRelTo := CrossConnection.OldIDCompRelTo; end; end; end; end; end; end; CompRelPath.Delete(0); if ACompRelPath = nil then FreeAndNil(CompRelPath); end; *) //*** Проверяет вместимость пути комплектующих на подключениях, в пути комплектующих function CheckCrossConnectionPathInCompRelPath(ACrossConnectionPath, ACompRelPath: TIntList): Boolean; var CompRelPathLastIndex: Integer; i: integer; begin Result := true; if ACrossConnectionPath.Count <= ACompRelPath.Count then begin //*** Проверить, правильный ли путь из конца пути комплектующих CompRelPathLastIndex := ACompRelPath.Count - 1; for i := ACrossConnectionPath.Count-1 downto 0 do begin if ACrossConnectionPath[i] <> ACompRelPath[CompRelPathLastIndex] then begin Result := false; Break; //// BREAK //// end; Dec(CompRelPathLastIndex); if CompRelPathLastIndex = -1 then Break; //// BREAK //// end; end else Result := false; end; //*** Определить путь комплектующих на подключениях из пути комплектующих function DefineNewCrossConnectionPathFromCompRelPath(ACrossConnectionPath, ACompRelPath: TIntList): Boolean; var CompRelPathLastIndex: Integer; i: integer; begin Result := false; if ACrossConnectionPath.Count <= ACompRelPath.Count then begin //*** Определить путь из конца пути комплектующих CompRelPathLastIndex := ACompRelPath.Count - 1; for i := ACrossConnectionPath.Count-1 downto 0 do begin ACrossConnectionPath[i] := ACompRelPath[CompRelPathLastIndex]; Dec(CompRelPathLastIndex); if CompRelPathLastIndex = -1 then Break; //// BREAK //// end; Result := true; end; end; procedure DefineIndividualComplectsForParents(AComplect: PComplect; ACrossConnections: TObjectList; ACompRelPathOldIDs, ACompRelPathNewIDs: TIntList; ATopComponID, AIDParentCompRel, AStepIndex: Integer); var i, j, k: Integer; ptrComplect: PComplect; KolSubComplect: Integer; IndexOfComplect: Integer; ListNewID: TIntList; CrossConnection: TSCSCrossConnection; FindedIDCompRel: Boolean; SavedLastGenIDCompRel: Integer; CompRelPathOldIDs: TIntList; CompRelPathNewIDs: TIntList; //CompRelPathLastIndex: Integer; //IsActualPath: Boolean; //CrossSideType: Integer; //CrossConnectionIndex: Integer; //PathList: TIntList; //IndexID: Integer; begin CompRelPathOldIDs := nil; CompRelPathNewIDs := nil; if ACompRelPathOldIDs <> nil then CompRelPathOldIDs := ACompRelPathOldIDs else CompRelPathOldIDs := TIntList.Create; if ACompRelPathNewIDs <> nil then CompRelPathNewIDs := ACompRelPathNewIDs else CompRelPathNewIDs := TIntList.Create; CompRelPathOldIDs.Insert(0, AComplect.ID); CompRelPathNewIDs.Insert(0, AIDParentCompRel); for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; if ptrComplect.ID_Component = AComplect.ID_Child then begin ListNewID := nil; ListNewID := TIntList(ListOfListNewID[i]); AQOperat.Close; AQOperat.ParamByName(fnIDComponent).AsInteger := ptrComplect.ID_Component; AQOperat.ParamByName(fnIDChild).AsInteger := ptrComplect.ID_Child; AQOperat.ParamByName(fnIDTopCompon).AsInteger := ATopComponID; AQOperat.ParamByName(fnIDParentCompRel).AsInteger := AIDParentCompRel; AQOperat.ParamByName(fnKolSubComplect).AsInteger := ptrComplect.KolSubComplect; AQOperat.ParamByName(fnKolvo).AsInteger := ptrComplect.Kolvo; AQOperat.ParamByName(fnConnectType).AsInteger := ptrComplect.ConnectType; AQOperat.ParamByName(fnSortID).AsInteger := ptrComplect.SortID; AQOperat.ExecQuery; //*** Определить новый ID Inc(LastGenIDCompRel); if ListNewID <> nil then ListNewID.Add(LastGenIDCompRel); SavedLastGenIDCompRel := LastGenIDCompRel; //*** Тело рекурсии DefineIndividualComplectsForParents(ptrComplect, ACrossConnections, CompRelPathOldIDs, CompRelPathNewIDs, ATopComponID, LastGenIDCompRel, AStepIndex+1); end; end; FindedIDCompRel := false; for i := 0 to ACrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(ACrossConnections[i]); if (CrossConnection.IDCompRelFrom = AComplect.ID) and CheckCrossConnectionPathInCompRelPath(CrossConnection.CompRelFromPath, CompRelPathOldIDs) then begin CrossConnection.IDCompRelFrom := AIDParentCompRel; DefineNewCrossConnectionPathFromCompRelPath(CrossConnection.CompRelFromPath, CompRelPathNewIDs); FindedIDCompRel := true; end else if (CrossConnection.IDCompRelTo = AComplect.ID) and CheckCrossConnectionPathInCompRelPath(CrossConnection.CompRelToPath, CompRelPathOldIDs) then begin CrossConnection.IDCompRelTo := AIDParentCompRel; DefineNewCrossConnectionPathFromCompRelPath(CrossConnection.CompRelToPath, CompRelPathNewIDs); FindedIDCompRel := true; end; if FindedIDCompRel then Break; //// BREAK //// end; CompRelPathOldIDs.Delete(0); CompRelPathNewIDs.Delete(0); if ACompRelPathOldIDs = nil then FreeAndNil(CompRelPathOldIDs); if ACompRelPathNewIDs = nil then FreeAndNil(CompRelPathNewIDs); end; begin try //*** отобрать инфу о комплектации с неопределенным полем idtopcompon SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentRelation, '(('+fnIDTopCompon+' is null) or ('+fnIDTopCompon+' = 0)) and '+ '('+fnConnectType+' = '''+IntToStr(cntComplect)+''')', nil, fnAll)); NoDefinedComplects := TList.Create; while Not AQSelect.Eof do begin GetZeroMem(ptrComplect, SizeOf(TComplect)); NoDefinedComplects.Add(ptrComplect); ptrComplect.ID := AQSelect.FN(fnID).AsInteger; ptrComplect.ID_Component := AQSelect.FN(fnIDComponent).AsInteger; ptrComplect.ID_Child := AQSelect.FN(fnIDChild).AsInteger; ptrComplect.Kolvo := AQSelect.FN(fnKolvo).AsInteger; ptrComplect.ConnectType := AQSelect.FN(fnConnectType).AsInteger; ptrComplect.SortID := AQSelect.FN(fnSortID).AsInteger; AQSelect.Next; end; if NoDefinedComplects.Count > 0 then begin ListOfListNewID := TObjectList.Create(true); ListOfComplectIOfIRels := TObjectList.Create(true); for i := 0 to NoDefinedComplects.Count - 1 do begin ListOfListNewID.Add(TIntList.Create); ListOfComplectIOfIRels.Add(TList.Create); end; ChildComplectPath := TList.Create; InterfRelIDsToNoBusy := TIntList.Create; AllCrossConnections := TObjectList.Create(true); ComponCrossConnections := TObjectList.Create(false); FieldNames := TStringList.Create; //*** Отобрать связи интерфейсов, касающихся комплектации SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnInterfOfInterfRelation, fnIDCompRel+' = :'+fnIDCompRel, nil, fnAll), false); for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; ComplectIOfIRels := TList(ListOfComplectIOfIRels[i]); AQSelect.Params[0].AsInteger := ptrComplect.ID; AQSelect.ExecQuery; while Not AQSelect.Eof do begin GetZeroMem(ptrIOfIRel, SizeOf(TIOfIRel)); ComplectIOfIRels.Add(ptrIOfIRel); ptrIOfIRel.IDInterfRel := AQSelect.FN(fnIDInterfRel).AsInteger; ptrIOfIRel.IDInterfTo := AQSelect.FN(fnIDInterfTo).AsInteger; if InterfRelIDsToNoBusy.IndexOf(ptrIOfIRel.IDInterfRel) = -1 then InterfRelIDsToNoBusy.Add(ptrIOfIRel.IDInterfRel); AQSelect.Next; end; end; //*** Отобрать внутрикомпонентные подключения - не кроссовые SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnCrossConnection, fnIDCompRelWith+' is null', nil, fnAll)); while Not AQSelect.Eof do begin CrossConnection := TSCSCrossConnection.Create(nil); CrossConnection.LoadFromQuery(AQSelect); CrossConnection.OldIDCompRelFrom := CrossConnection.IDCompRelFrom; CrossConnection.OldIDCompRelTo := CrossConnection.IDCompRelTo; AllCrossConnections.Add(CrossConnection); AQSelect.Next; end; //*** Отобрать пути найденных внутрикомпонентных подключений if AllCrossConnections.Count > 0 then begin SetSQLToFIBQuery(AQSelect, 'select '+fnIDCompRel+', '+fnPathType+' from '+tnCrossConnectionPath+ ' where '+fnIDCrossConnection+' = :'+fnIDCrossConnection+' order by '+fnID, false); for i := 0 to AllCrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(AllCrossConnections[i]); AQSelect.Close; AQSelect.Params[0].AsInteger := CrossConnection.ID; AQSelect.ExecQuery; while Not AQSelect.Eof do begin case AQSelect.Fields[1].AsInteger of ptFrom: CrossConnection.CompRelFromPath.Add(AQSelect.Fields[0].AsInteger); ptTo: CrossConnection.CompRelToPath.Add(AQSelect.Fields[0].AsInteger); end; AQSelect.Next; end; end; end; SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try FieldNames.Clear; FieldNames.Add(fnIDTopCompon); FieldNames.Add(fnKolSubComplect); if NoDefinedComplects.Count > 0 then begin //*** коррекция fnIDTopCompon, fnKolSubComplect для собственных комплектующих SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnComponentRelation, fnID+' = :'+fnID, FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; ptrComplect.KolSubComplect := GetKolSubComplect(ptrComplect); AQOperat.Close; AQOperat.Params[0].AsInteger := ptrComplect.ID_Component; AQOperat.Params[1].AsInteger := ptrComplect.KolSubComplect; AQOperat.Params[2].AsInteger := ptrComplect.ID; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; end; //*** Вкинуть подкомплектующие FieldNames.Clear; FieldNames.Add(fnIDComponent); FieldNames.Add(fnIDChild); FieldNames.Add(fnIDTopCompon); FieldNames.Add(fnIDParentCompRel); FieldNames.Add(fnKolSubComplect); FieldNames.Add(fnKolvo); FieldNames.Add(fnConnectType); FieldNames.Add(fnSortID); //*** узнать последний сгенерированный ID LastGenIDCompRel := GenIDFromTable(AQSelect, gnComponentRelationID, 0); SetSQlToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentRelation, '', nil, 'Max('+fnID+')'), true); MaxIDCompRel := AQSelect.Fields[0].AsInteger; if LastGenIDCompRel < MaxIDCompRel then LastGenIDCompRel := GenIDFromTable(AQSelect, gnComponentRelationID, (MaxIDCompRel-LastGenIDCompRel)+1); //*** запрос для вкидки if NoDefinedComplects.Count > 0 then begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnComponentRelation, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; LoadCrossConnectionsToListByIDTopComponent(ptrComplect.ID_Component, ComponCrossConnections); //DefineIndividualComplectsForParents(ptrComplect, ComponCrossConnections, nil, nil, nil, // ptrComplect.ID_Component, ptrComplect.ID, 0); DefineIndividualComplectsForParents(ptrComplect, ComponCrossConnections, nil, nil, ptrComplect.ID_Component, ptrComplect.ID, 0); end; AQOperat.Transaction.Commit; end; //*** вставить инфу о связи интерфейсов, для добавленной инфы о комплектации FieldNames.Clear; FieldNames.Add(fnIDInterfRel); FieldNames.Add(fnIDInterfTo); FieldNames.Add(fnIDCompRel); if ListOfListNewID.Count > 0 then begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnInterfOfInterfRelation, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to ListOfListNewID.Count - 1 do begin ListNewID := TIntList(ListOfListNewID[i]); if ListNewID.Count > 0 then begin ComplectIOfIRels := TList(ListOfComplectIOfIRels[i]); for j := 0 to ListNewID.Count - 1 do for k := 0 to ComplectIOfIRels.Count - 1 do begin ptrIOfIRel := ComplectIOfIRels[k]; if (ptrIOfIRel.IDInterfRel > 0) and (ptrIOfIRel.IDInterfTo > 0) then begin AQOperat.Close; AQOperat.ParamByName(fnIDInterfRel).AsInteger := ptrIOfIRel.IDInterfRel; AQOperat.ParamByName(fnIDInterfTo).AsInteger := ptrIOfIRel.IDInterfTo; AQOperat.ParamByName(fnIDCompRel).AsInteger := ListNewID[j]; AQOperat.ExecQuery; end else EmptyProcedure; end; end; end; AQOperat.Transaction.Commit; end; //*** Сбросить влаг IsBusy в следубщих интерфейсов SetSQLToFIBQuery(AQOperat, 'update '+tnInterfaceRelation+' set '+fnIsBusy+' = '''+IntToStr(biFalse)+''' ', false); AQOperat.Transaction.StartTransaction; AQOperat.ExecQuery; AQOperat.Transaction.Commit; if AllCrossConnections.Count > 0 then begin //*** Внести инфу о измененных IDCompRel внутрикомпонентных подключений FieldNames.Clear; FieldNames.Add(fnIDCompRelFrom); FieldNames.Add(fnIDCompRelTo); SetSQlToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnCrossConnection, fnID+' = :'+fnID, FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to AllCrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(AllCrossConnections[i]); AQOperat.Close; AQOperat.Params[0].AsInteger := CrossConnection.IDCompRelFrom; AQOperat.Params[1].AsInteger := CrossConnection.IDCompRelTo; AQOperat.Params[2].AsInteger := CrossConnection.ID; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; //*** Удалить старые пути к подключенным комплектующим SetSQlToFIBQuery(AQOperat, GetSQLByParams(qtDelete, tnCrossConnectionPath, fnIDCrossConnection+' = :'+fnIDCrossConnection, nil, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to AllCrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(AllCrossConnections[i]); AQOperat.Close; AQOperat.Params[0].AsInteger := CrossConnection.ID; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; //*** Внести новые пути к подключенным комплектующим FieldNames.Clear; FieldNames.Add(fnIDCrossConnection); FieldNames.Add(fnIDCompRel); FieldNames.Add(fnPathType); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnCrossConnectionPath, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to AllCrossConnections.Count - 1 do begin CrossConnection := TSCSCrossConnection(AllCrossConnections[i]); for j := 0 to CrossConnection.CompRelFromPath.Count - 1 do begin AQOperat.Close; AQOperat.Params[0].AsInteger := CrossConnection.ID; AQOperat.Params[1].AsInteger := CrossConnection.CompRelFromPath[j]; AQOperat.Params[2].AsInteger := ptFrom; AQOperat.ExecQuery; end; for j := 0 to CrossConnection.CompRelToPath.Count - 1 do begin AQOperat.Close; AQOperat.Params[0].AsInteger := CrossConnection.ID; AQOperat.Params[1].AsInteger := CrossConnection.CompRelToPath[j]; AQOperat.Params[2].AsInteger := ptTo; AQOperat.ExecQuery; end; end; AQOperat.Transaction.Commit; end; {if InterfRelIDsToNoBusy.Count > 0 then begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnInterfaceRelation, fnID+' = :'+fnID, nil, fnIsBusy), false); AQOperat.Transaction.StartTransaction; for i := 0 to InterfRelIDsToNoBusy.Count - 1 do begin AQOperat.Close; AQOperat.Params[0].AsInteger := biFalse; //IsBusy AQOperat.Params[1].AsInteger := InterfRelIDsToNoBusy[i]; // InterfRelID AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; end;} finally AQOperat.Options := SavedQOperatOptions; FreeAndNil(FieldNames); FreeAndNil(ComponCrossConnections); FreeAndNil(AllCrossConnections); FreeAndNil(InterfRelIDsToNoBusy); FreeAndNil(ChildComplectPath); FreeAndNil(ListOfListNewID); //*** Очистить айтемы листов for i := 0 to ListOfComplectIOfIRels.Count - 1 do for j := 0 to TList(ListOfComplectIOfIRels[i]).Count - 1 do FreeMem(TList(ListOfComplectIOfIRels[i])[j]); FreeAndNil(ListOfComplectIOfIRels); end; end; FreeList(NoDefinedComplects); except on E: Exception do AddExceptionToLogEx('DefineIndividualComplectsByEmptyIDTopCompon', E.Message); end; end; (* procedure DefineIndividualComplectsByEmptyIDTopCompon(AQSelect, AQOperat: TpFIBQuery); var // i-е елементы взаемосвязаны NoDefinedComplects: TList; ListOfComplectIOfIRels: TObjectList; // список списков(TList) о инфе связанных интерфейсов на компоновке ListOfListNewID: TObjectList; // список списков(TIntList) новых id-в для NoDefinedComplects[i] InterfRelIDsToNoBusy: TIntList; // ID Интерфейсов для сброса флага IsBusy ComplectIOfIRels: TList; ListNewID: TintList; ptrComplect: PComplect; ptrIOfIRel: PIOfIRel; i, j, k: Integer; SavedQOperatOptions: TpFIBQueryOptions; ChildComplectPath: TList; FieldNames: TStringList; LastGenIDCompRel: Integer; // Вернет кол-во подкомплектующих function GetKolSubComplect(AComplect: PComplect): Integer; var i: integer; ptrComplect: PComplect; begin Result := 0; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; if ptrComplect <> AComplect then if ptrComplect.ID_Component = AComplect.ID_Child then Inc(Result); end; end; procedure DefineIndividualComplectsForParents(AComplect: PComplect; ATopComponID, AIDParentCompRel, AStepIndex: Integer); var i, j, k: Integer; ptrComplect: PComplect; KolSubComplect: Integer; IndexOfComplect: Integer; ListNewID: TIntList; begin for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; if ptrComplect.ID_Component = AComplect.ID_Child then begin ListNewID := nil; ListNewID := TIntList(ListOfListNewID[i]); AQOperat.Close; AQOperat.ParamByName(fnIDComponent).AsInteger := ptrComplect.ID_Component; AQOperat.ParamByName(fnIDChild).AsInteger := ptrComplect.ID_Child; AQOperat.ParamByName(fnIDTopCompon).AsInteger := ATopComponID; AQOperat.ParamByName(fnIDParentCompRel).AsInteger := AIDParentCompRel; AQOperat.ParamByName(fnKolSubComplect).AsInteger := ptrComplect.KolSubComplect; AQOperat.ParamByName(fnKolvo).AsInteger := ptrComplect.Kolvo; AQOperat.ParamByName(fnConnectType).AsInteger := ptrComplect.ConnectType; AQOperat.ParamByName(fnSortID).AsInteger := ptrComplect.SortID; AQOperat.ExecQuery; //*** Определить новый ID Inc(LastGenIDCompRel); if ListNewID <> nil then ListNewID.Add(LastGenIDCompRel); DefineIndividualComplectsForParents(ptrComplect, ATopComponID, LastGenIDCompRel, AStepIndex+1); end; end; end; begin //*** отобрать инфу о комплектации с неопределенным полем idtopcompon SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentRelation, '(('+fnIDTopCompon+' is null) or ('+fnIDTopCompon+' = 0)) and '+ '('+fnConnectType+' = '''+IntToStr(cntComplect)+''')', nil, fnAll)); NoDefinedComplects := TList.Create; while Not AQSelect.Eof do begin GetZeroMem(ptrComplect, SizeOf(TComplect)); NoDefinedComplects.Add(ptrComplect); ptrComplect.ID := AQSelect.FN(fnID).AsInteger; ptrComplect.ID_Component := AQSelect.FN(fnIDComponent).AsInteger; ptrComplect.ID_Child := AQSelect.FN(fnIDChild).AsInteger; ptrComplect.Kolvo := AQSelect.FN(fnKolvo).AsInteger; ptrComplect.ConnectType := AQSelect.FN(fnConnectType).AsInteger; ptrComplect.SortID := AQSelect.FN(fnSortID).AsInteger; AQSelect.Next; end; if NoDefinedComplects.Count > 0 then begin ListOfListNewID := TObjectList.Create(true); ListOfComplectIOfIRels := TObjectList.Create(true); for i := 0 to NoDefinedComplects.Count - 1 do begin ListOfListNewID.Add(TIntList.Create); ListOfComplectIOfIRels.Add(TList.Create); end; ChildComplectPath := TList.Create; InterfRelIDsToNoBusy := TIntList.Create; FieldNames := TStringList.Create; //*** Отобрать связи интерфейсов, касающихся комплектации SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnInterfOfInterfRelation, fnIDCompRel+' = :'+fnIDCompRel, nil, fnAll), false); for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; ComplectIOfIRels := TList(ListOfComplectIOfIRels[i]); AQSelect.Params[0].AsInteger := ptrComplect.ID; AQSelect.ExecQuery; while Not AQSelect.Eof do begin GetZeroMem(ptrIOfIRel, SizeOf(TIOfIRel)); ComplectIOfIRels.Add(ptrIOfIRel); ptrIOfIRel.IDInterfRel := AQSelect.FN(fnIDInterfRel).AsInteger; ptrIOfIRel.IDInterfTo := AQSelect.FN(fnIDInterfTo).AsInteger; if InterfRelIDsToNoBusy.IndexOf(ptrIOfIRel.IDInterfRel) = -1 then InterfRelIDsToNoBusy.Add(ptrIOfIRel.IDInterfRel); AQSelect.Next; end; end; SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try FieldNames.Clear; FieldNames.Add(fnIDTopCompon); FieldNames.Add(fnKolSubComplect); //*** коррекция fnIDTopCompon, fnKolSubComplect для собственных комплектующих SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnComponentRelation, fnID+' = :'+fnID, FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; ptrComplect.KolSubComplect := GetKolSubComplect(ptrComplect); AQOperat.Close; AQOperat.Params[0].AsInteger := ptrComplect.ID_Component; AQOperat.Params[1].AsInteger := ptrComplect.KolSubComplect; AQOperat.Params[2].AsInteger := ptrComplect.ID; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; //*** Вкинуть подкомплектующие FieldNames.Clear; FieldNames.Add(fnIDComponent); FieldNames.Add(fnIDChild); FieldNames.Add(fnIDTopCompon); FieldNames.Add(fnIDParentCompRel); FieldNames.Add(fnKolSubComplect); FieldNames.Add(fnKolvo); FieldNames.Add(fnConnectType); FieldNames.Add(fnSortID); //*** узнать последний сгенерированный ID LastGenIDCompRel := GenIDFromTable(AQSelect, gnComponentRelationID, 0); //*** запрос для вкидки SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnComponentRelation, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to NoDefinedComplects.Count - 1 do begin ptrComplect := NoDefinedComplects[i]; DefineIndividualComplectsForParents(ptrComplect, ptrComplect.ID_Component, ptrComplect.ID, 0); end; AQOperat.Transaction.Commit; //*** вставить инфу о связи интерфейсов, для добавленной инфы о комплектации FieldNames.Clear; FieldNames.Add(fnIDInterfRel); FieldNames.Add(fnIDInterfTo); FieldNames.Add(fnIDCompRel); SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnInterfOfInterfRelation, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to ListOfListNewID.Count - 1 do begin ListNewID := TIntList(ListOfListNewID[i]); if ListNewID.Count > 0 then begin ComplectIOfIRels := TList(ListOfComplectIOfIRels[i]); for j := 0 to ListNewID.Count - 1 do for k := 0 to ComplectIOfIRels.Count - 1 do begin ptrIOfIRel := ComplectIOfIRels[k]; if (ptrIOfIRel.IDInterfRel > 0) and (ptrIOfIRel.IDInterfTo > 0) then begin AQOperat.Close; AQOperat.ParamByName(fnIDInterfRel).AsInteger := ptrIOfIRel.IDInterfRel; AQOperat.ParamByName(fnIDInterfTo).AsInteger := ptrIOfIRel.IDInterfTo; AQOperat.ParamByName(fnIDCompRel).AsInteger := ListNewID[j]; AQOperat.ExecQuery; end else EmptyProcedure; end; end; end; AQOperat.Transaction.Commit; //*** Сбросить влаг IsBusy в следубщих интерфейсов SetSQLToFIBQuery(AQOperat, 'update '+tnInterfaceRelation+' set '+fnIsBusy+' = '''+IntToStr(biFalse)+''' ', false); AQOperat.Transaction.StartTransaction; AQOperat.ExecQuery; AQOperat.Transaction.Commit; {if InterfRelIDsToNoBusy.Count > 0 then begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnInterfaceRelation, fnID+' = :'+fnID, nil, fnIsBusy), false); AQOperat.Transaction.StartTransaction; for i := 0 to InterfRelIDsToNoBusy.Count - 1 do begin AQOperat.Close; AQOperat.Params[0].AsInteger := biFalse; //IsBusy AQOperat.Params[1].AsInteger := InterfRelIDsToNoBusy[i]; // InterfRelID AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; end;} finally AQOperat.Options := SavedQOperatOptions; FreeAndNil(FieldNames); FreeAndNil(InterfRelIDsToNoBusy); FreeAndNil(ChildComplectPath); FreeAndNil(ListOfListNewID); //*** Очистить айтемы листов for i := 0 to ListOfComplectIOfIRels.Count - 1 do for j := 0 to TList(ListOfComplectIOfIRels[i]).Count - 1 do FreeMem(TList(ListOfComplectIOfIRels[i])[j]); FreeAndNil(ListOfComplectIOfIRels); end; end; FreeList(NoDefinedComplects); end; *) procedure DefinePropSectionForLineCompons(AQSelect, AQOperat: TpFIBQuery; const APropSysName: String; ACompTypeSysNames: TStringList; ASrcInterfGender: ShortInt; ASetZeroIfNoValue: Boolean); var SQLWhere: String; SQLWhereProps: string; SQLWhereCompTypes: string; i: Integer; IDPropertyToAdd: Integer; IDCompons: TIntList; ComponSections: TStringList; ComponSection: Double; FieldNames: TStringList; SavedQOperatOptions: TpFIBQueryOptions; begin try SQLWhere := ''; // Определяем ID свойств SQLWhereProps := ''; IDPropertyToAdd := 0; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnProperties, fnSysName+' = :'+fnSysName, nil, fnID), false); AQSelect.Params[0].AsString := APropSysName; AQSelect.ExecQuery; while Not AQSelect.Eof do begin if SQLWhereProps <> '' then SQLWhereProps := SQLWhereProps + snCommaS; SQLWhereProps := SQLWhereProps + IntToStr(AQSelect.Fields[0].AsInteger); if IDPropertyToAdd = 0 then IDPropertyToAdd := AQSelect.Fields[0].AsInteger; AQSelect.Next; end; // Определяем ID типов компонентов SQLWhereCompTypes := ''; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponentTypes, fnSysName+' = :'+fnSysName, nil, fnID), false); for i := 0 to ACompTypeSysNames.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsString := ACompTypeSysNames[i]; AQSelect.ExecQuery; while Not AQSelect.Eof do begin if SQLWhereCompTypes <> '' then SQLWhereCompTypes := SQLWhereCompTypes + snCommaS; SQLWhereCompTypes := SQLWhereCompTypes + IntToStr(AQSelect.Fields[0].AsInteger); AQSelect.Next; end; end; if (SQLWhereProps <> '') and (SQLWhereCompTypes <> '') then begin // Выбираем все ID компонентов без этого свойства //SQLWhere := '(COMPONENT.ID = COMP_PROP_RELATION.ID_COMPONENT) AND '+ // '('+tnComponent +snPoint+ fnIDComponentType +' IN ('+SQLWhereCompTypes+')) AND '+ // 'NOT ('+tnCompPropRelation +snPoint+ fnIDProperty + ' IN ('+SQLWhereProps+'))'; //SetSQLToFIBQuery(AQSelect, // GetSQLByParams(qtSelect, tnComponent + snCommaS + tnCompPropRelation, SQLWhere, nil, tnComponent+snPoint+fnID), false); //AQSelect.SQL.Text := AQSelect.SQL.Text + ' group by '+tnComponent+snPoint+fnID; SQLWhere := '('+ fnIDComponentType +' IN ('+SQLWhereCompTypes+')) AND '+ 'NOT ('+fnID+' IN (SELECT '+fnIDComponent+' from ' +tnCompPropRelation +' where '+ fnIDProperty +' IN ('+SQLWhereProps+')))'; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponent, SQLWhere, nil, tnComponent+snPoint+fnID), false); AQSelect.ExecQuery; IDCompons := TIntList.Create; IntFIBFieldToIntList(IDCompons, AQSelect, fnID); if IDCompons.Count > 0 then begin // Определяем сечение из емкостного интерфейса компонента SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnInterfaceRelation, '('+fnIDComponent+' = :'+fnIDComponent+') AND '+ '('+fnTypeI+' = '''+IntToStr(itConstructive)+''') AND '+ '('+fnMultiple+' = '''+IntToStr(biTrue)+''') AND '+ '('+fnGender+' = '''+IntToStr(ASrcInterfGender)+''')', nil, fnValueI), false); ComponSections := TStringList.Create; for i := 0 to IDCompons.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsInteger := IDCompons[i]; AQSelect.ExecQuery; if AQSelect.RecordCount > 0 then begin ComponSection := AQSelect.Fields[0].AsFloat; // Преобразуем из см2 в мм2 ComponSection := FloatInUOM(ComponSection, umSM, umMM, 2); ComponSections.Add(FloatToStrU(ComponSection)); end else if ASetZeroIfNoValue then ComponSections.Add(IntToStr(0)) else ComponSections.Add(''); end; FieldNames := TStringList.Create; FieldNames.Add(fnGUID); FieldNames.Add(fnIDComponent); FieldNames.Add(fnIDProperty); FieldNames.Add(fnPValue); SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtInsert, tnCompPropRelation, '', FieldNames, ''), false); AQOperat.Transaction.StartTransaction; for i := 0 to IDCompons.Count - 1 do if ComponSections[i] <> '' then begin AQOperat.Close; AQOperat.Params[0].AsString := CreateGUID; AQOperat.Params[1].AsInteger := IDCompons[i]; AQOperat.Params[2].AsInteger := IDPropertyToAdd; AQOperat.Params[3].AsString := ComponSections[i]; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; AQOperat.Close; finally AQOperat.Options := SavedQOperatOptions; end; FreeAndNil(FieldNames); FreeAndNil(ComponSections); end; FreeAndNil(IDCompons); end; except on E: Exception do AddExceptionToLogEx('DefinePropSectionForLineCompons', E.Message); end; end; procedure ChangeComponentCypher(ANewCypherPart: String; AIndex: Integer; AQSelect, AQOperat: TpFIBQuery); var ComponIDs: TIntList; Cyphers: TStringList; CurrCypher: String; SelectFields: TStringList; CypherPartLen: Integer; i: Integer; begin ComponIDs := TIntList.Create; Cyphers := TStringList.Create; SelectFields := TStringList.Create; try SelectFields.Add(fnID); SelectFields.Add(fnCypher); SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, tnComponent, '', SelectFields, '')); while Not AQSelect.Eof do begin ComponIDs.Add(AQSelect.FN(fnID).AsInteger); Cyphers.Add(AQSelect.FN(fnCypher).AsString); AQSelect.Next; end; //*** пологнать новые значения SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, tnComponent, fnID+' = :'+fnID, nil, fnCypher), false); CypherPartLen := Length(ANewCypherPart); for i := 0 to ComponIDs.Count - 1 do begin CurrCypher := Cyphers[i]; if (Length(CurrCypher) - (AIndex - 1)) >= CypherPartLen then begin Delete(CurrCypher, AIndex, CypherPartLen); Insert(ANewCypherPart, CurrCypher, AIndex); AQOperat.Close; AQOperat.ParamByName(fnID).AsInteger := ComponIDs[i]; AQOperat.ParamByName(fnCypher).AsString := CurrCypher; AQOperat.ExecQuery; end; end; finally FreeAndNil(ComponIDs); FreeAndNil(Cyphers); FreeAndNil(SelectFields); end; end; { procedure AddPropertyToComponents(AIDComponentType, AIDProperty: Integer); var IDList: TIntList; SCSComponent: TSCSComponent; i: Integer; ptrNewProperty: PProperty; PropertyData: TPropertyData; begin with F_NormBase do begin PropertyData := DM.GetPropertyData(AIDProperty); IDList := TIntList.Create; SCSComponent := TSCSComponent.Create(F_NormBase); try SetSQLToFIBQuery(DM.Query_Select, GetSQLByParams(qtSelect, tnComponent, fnIDComponentType+' = '''+IntToStr(AIDComponentType)+'''', nil, fnID)); IntFIBFieldToIntList(IDList, DM.Query_Select, fnID); for i := 0 to IDList.Count - 1 do begin SCSComponent.Clear; SCSComponent.LoadComponentByID(IDList[i], false); ptrNewProperty := SCSComponent.GetPropertyAsNew; ptrNewProperty.ID_Property := PropertyData.ID; ptrNewProperty.Value := PropertyData.DefValue; ptrNewProperty.IsDefault := biTrue; SCSComponent.SaveProperty(meMake, ptrNewProperty); end; finally IDList.Free; SCSComponent.Free; end; end; end;} procedure RecalcNBComponentPrices; var ComponIDs: TIntList; i: Integer; begin ComponIDs := TIntList.Create; try with F_NormBase do begin SetSQLToFIBQuery(DM.Query_Select, GetSQLByParams(qtSelect, tnComponent, '', nil, fnID)); IntFIBFieldToIntList(ComponIDs, DM.Query_Select, fnID); F_Animate.GMaxProgressPos := ComponIDs.Count; F_Animate.StartAnimate(cBaseCommon30, aviCopyFiles, aiProgressBar); try for i := 0 to ComponIDs.Count - 1 do begin CalcPriceForParents(ComponIDs[i]); F_Animate.SetProgressPos(i); end; finally F_Animate.StopAnimate; end; end; finally ComponIDs.Free; end; end; function GetCableChannelElementByName(const ATypeName: String): Integer; var TypeNameUpper: String; begin Result := contNone; TypeNameUpper := AnsiUpperCase(ATypeName); if TypeNameUpper = AnsiUpperCase(ctnCork) then Result := contCork else if TypeNameUpper = AnsiUpperCase(ctnAnglePlane) then Result := contAnglePlane else if TypeNameUpper = AnsiUpperCase(ctnTjoin) then Result := contTjoin else if TypeNameUpper = AnsiUpperCase(ctnAngleIn) then Result := contAngleIn else if TypeNameUpper = AnsiUpperCase(ctnAngleOut) then Result := contAngleOut else if TypeNameUpper = AnsiUpperCase(ctnADapter) then Result := contADapter else if TypeNameUpper = AnsiUpperCase(ctnConnector) then Result := contConnector else if TypeNameUpper = AnsiUpperCase(ctnWallCork) then Result := contWallCork else if TypeNameUpper = AnsiUpperCase(ctnCross) then Result := contCross; end; function GetCableChannelElementName(ATypeIndex: Integer): String; begin Result := ''; if ATypeIndex = contCork then Result := ctnCork else if ATypeIndex = contAnglePlane then Result := ctnAnglePlane else if ATypeIndex = contTjoin then Result := ctnTjoin else if ATypeIndex = contAngleIn then Result := ctnAngleIn else if ATypeIndex = contAngleOut then Result := ctnAngleOut else if ATypeIndex = contADapter then Result := ctnADapter else if ATypeIndex = contConnector then Result := ctnConnector else if ATypeIndex = contWallCork then Result := ctnWallCork else if ATypeIndex = contCross then Result := ctnCross; end; function GetCompStateTypeName(AType: Integer): string; begin Result := ''; case AType of oitProjectible: Result := cDM_Msg1; oitActive: Result := cDM_Msg2; end; end; function GetCCEGuid(ATypeIndex: Integer): String; begin Result := ''; if ATypeIndex = contCork then Result := guidCCECork else if ATypeIndex = contAnglePlane then Result := guidCCEAnglePlane else if ATypeIndex = contTjoin then Result := guidCCETjoin else if ATypeIndex = contAngleIn then Result := guidCCEAngleIn else if ATypeIndex = contAngleOut then Result := guidCCEAngleOut else if ATypeIndex = contADapter then Result := guidCCEADapter else if ATypeIndex = contConnector then Result := guidCCEConnector else if ATypeIndex = contWallCork then Result := guidCCEWallCork else if ATypeIndex = contCross then Result := guidCCECross; end; function GetConnectionRelTypeName(AValue: Integer): String; begin Result := ''; case AValue of crtDirect: Result := crtnDirect; crtReverse: Result := crtnReverse; end; end; function GetDataTypeName(ADataTypeID: Integer): String; begin Result := ''; if ADataTypeID = 1 then Result := cCaseForm_Msg21_1 else if ADataTypeID = 2 then Result := cCaseForm_Msg21_2 else if ADataTypeID = 3 then Result := cCaseForm_Msg21_3 else if ADataTypeID = 4 then Result := cCaseForm_Msg21_4 else if ADataTypeID = 5 then Result := cCaseForm_Msg21_5 else if ADataTypeID = 6 then Result := cCaseForm_Msg21_6 else if ADataTypeID = dtColor then Result := cCaseForm_Msg21_7 else if ADataTypeID = dtCableCanalElementType then Result := cCaseForm_Msg21_8 else if ADataTypeID = dtDimensions then Result := cDimensionsB else if ADataTypeID = dtConnectionKind then Result := cNameConnectionKind else if ADataTypeID = dtStringList then Result := cNameStringListB else if ADataTypeID = dtPlaneMaterialType then Result := cNamePlaneMaterialTypeB else if ADataTypeID = dtRoofHipType then Result := cNameRoofHipTypeB else if ADataTypeID = dtRoofHipApexType then Result := cNameRoofHipApexTypeB else if ADataTypeID = dtRoofHipValleyType then Result := cNameRoofHipValleyTypeB; end; function GetPlaneMaterialTypeName(AValue: Integer): String; begin Result := ''; //if AValue = pmtSheeting then // Result := pmtnSheeting //else if AValue = pmtRoll then // Result := pmtnRoll //else if AValue = pmtTile then // Result := pmtnTile; end; function GetResourceTypeName(AResTypeIndex: Integer): string; begin Result := ''; if AResTypeIndex = rtMat then Result := cAddComponent_Msg13_1 else if AResTypeIndex = rtMachMech then Result := cAddComponent_Msg13_2 else if AResTypeIndex = rtPrice then Result := cAddComponent_Msg13_3; end; function GetResourceTypeByName(const AResTypeName: string): Integer; var ResTypeUpper: String; begin Result := -1; ResTypeUpper := AnsiUpperCase(AResTypeName); if ResTypeUpper = AnsiUpperCase(cAddComponent_Msg13_1) then Result := rtMat else if ResTypeUpper = AnsiUpperCase(cAddComponent_Msg13_2) then Result := rtMachMech else if ResTypeUpper = AnsiUpperCase(cAddComponent_Msg13_3) then Result := rtPrice; end; function GetResourceTypeCorrectByCypher(const ACypher: string; ACurrResType: Integer): Integer; // проверяет, находится ли строка из списка вначале шифра function CheckStringsitemInCypher(AStrList: TStringList): Boolean; var i: Integer; begin Result := false; for i := 0 to AStrList.Count - 1 do begin if Pos(AStrList[i], ACypher) = 1 then begin Result := true; Break; //// BREAK //// end; end; end; begin Result := ACurrResType; F_NormBase.CreateFMakeNorm; if CheckStringsitemInCypher(F_NormBase.F_MakeNorm.ResMatCypherTitles) then Result := rtMat else if CheckStringsitemInCypher(F_NormBase.F_MakeNorm.ResMashMechCypherTitles) then Result := rtMachMech else if CheckStringsitemInCypher(F_NormBase.F_MakeNorm.ResPriceCypherTitles) then Result := rtPrice; end; function GetTubeConnectKindByName(const AConnectKindName: String): Integer; var ConnectKindNameUpper: String; begin Result := tckNone; ConnectKindNameUpper := AnsiUpperCase(AConnectKindName); if ConnectKindNameUpper = AnsiUpperCase(tcknHubOfPipe) then Result := tckHubOfPipe else if ConnectKindNameUpper = AnsiUpperCase(tcknCapillarySoldering) then Result := tckCapillarySoldering else if ConnectKindNameUpper = AnsiUpperCase(tcknMechanicalCompressive) then Result := tckMechanicalCompressive else if ConnectKindNameUpper = AnsiUpperCase(tcknMechanicalPress) then Result := tckMechanicalPress else if ConnectKindNameUpper = AnsiUpperCase(tcknMechanicalTread) then Result := tckMechanicalTread else if ConnectKindNameUpper = AnsiUpperCase(tcknPress) then Result := tckPress else if ConnectKindNameUpper = AnsiUpperCase(tcknWeldingConnection) then Result := tckWeldingConnection else if ConnectKindNameUpper = AnsiUpperCase(tcknWeldingButt) then Result := tckWeldingButt else if ConnectKindNameUpper = AnsiUpperCase(tcknWeldHubOfPipe) then Result := tckWeldHubOfPipe else if ConnectKindNameUpper = AnsiUpperCase(tcknWeldElectric) then Result := tckWeldElectric; end; function GetTubeConnectKindName(AConnectKindIndex: Integer): String; begin Result := ''; if AConnectKindIndex = tckHubOfPipe then Result := tcknHubOfPipe else if AConnectKindIndex = tckCapillarySoldering then Result := tcknCapillarySoldering else if AConnectKindIndex = tckMechanicalCompressive then Result := tcknMechanicalCompressive else if AConnectKindIndex = tckMechanicalPress then Result := tcknMechanicalPress else if AConnectKindIndex = tckMechanicalTread then Result := tcknMechanicalTread else if AConnectKindIndex = tckPress then Result := tcknPress else if AConnectKindIndex = tckWeldingConnection then Result := tcknWeldingConnection else if AConnectKindIndex = tckWeldingButt then Result := tcknWeldingButt else if AConnectKindIndex = tckWeldHubOfPipe then Result := tcknWeldHubOfPipe else if AConnectKindIndex = tckWeldElectric then Result := tcknWeldElectric; end; //*** Вид поствки function GetSuppliesKindByIzmAndKolvo(const AName, AIzm: String; AUnitKolvo: Double; ASuppliesKinds: TList): PSuppliesKind; var i: Integer; ptrSuppliesKind: PSuppliesKind; NameUpper: String; IzmUpper: String; begin Result := nil; NameUpper := AnsiUpperCase(AName); IzmUpper := AnsiUpperCase(AIzm); for i := 0 to ASuppliesKinds.Count - 1 do begin ptrSuppliesKind := ASuppliesKinds[i]; if (Abs(ptrSuppliesKind.UnitKolvo - AUnitKolvo) <= 0.001) and (AnsiUpperCase(ptrSuppliesKind.Izm) = IzmUpper) and ((NameUpper = '') or (AnsiUpperCase(ptrSuppliesKind.Name) = NameUpper)) then begin Result := ptrSuppliesKind; Break; //// BREAK //// end; end; end; function GetStringByTemplate(ASrcString, ATemplate: String): String; const FillCh = '0'; var DefisNpp: Integer; i, j: Integer; SrcPos: Integer; SrcNewPos: Integer; SrcSpaceLengthBetwDefis: Integer; SrcLength: Integer; SrcCh: Char; TemplSpaceLengthBetwDefis: Integer; TemplNextSpaceLengthBetwDefis: Integer; TemplateLength: Integer; TemplateCh: Char; DeltaInSpace: Integer; DeltaInLength: Integer; //---- TemplateSymbolCount: Integer; begin Result := ASrcString; DefisNpp := 0; TemplSpaceLengthBetwDefis := 0; SrcPos := 0; TemplateLength := Length(ATemplate); //*** Определить количество символов без дефиса TemplateSymbolCount := 0; for i := 0 to TemplateLength - 1 do if ATemplate[i+1] <> '-' then Inc(TemplateSymbolCount); //*** Удалить дефисы из Исходной строки i := 0; while i <= Length(Result) do begin if Result[i+1] = '-' then Delete(Result, i+1, 1) else inc(i); end; DeltaInLength := TemplateSymbolCount - Length(Result); //*** Добавить недостающие нули for i := 0 to DeltaInLength - 1 do Insert(FillCh, Result, 1); //*** Раставить дефисы for i := 0 to TemplateLength - 1 do begin if ATemplate[i+1] = '-' then Insert('-', Result, i+1); end; {TemplateLength := Length(ATemplate); for i := 0 to TemplateLength - 1 do begin TemplateCh := ATemplate[i+1]; if TemplateCh = '-' then begin //*** Определить размер следующего промежутка TemplNextSpaceLengthBetwDefis := 0; for j := i+2 to TemplateLength - 1 do begin if ATemplate[j+1] = '-' then Break; //// BREAK //// else Inc(TemplNextSpaceLengthBetwDefis); end; //*** Найти промежуток между дефисами в исходной строке SrcSpaceLengthBetwDefis := 0; SrcLength := Length(ASrcString); SrcNewPos := 0; for j := SrcPos to SrcLength - 1 do begin SrcCh := Result[j+1]; if SrcCh = '-' then begin SrcNewPos := j+2; Break; //// BREAK //// end else begin SrcNewPos := j+1; Inc(SrcSpaceLengthBetwDefis) end; end; //*** Добавить в начало недостающие символы с дэфисом if SrcSpaceLengthBetwDefis > TemplSpaceLengthBetwDefis then begin Insert('-', Result, SrcPos+1); DeltaInSpace := TemplSpaceLengthBetwDefis; for j := 0 to DeltaInSpace - 1 do Insert(FillCh, Result, SrcPos+1); SrcPos := SrcPos + DeltaInSpace + 1; SrcNewPos := SrcPos; end else //*** Добавить в начало недостающие символы без дэфисом if SrcSpaceLengthBetwDefis < TemplSpaceLengthBetwDefis then begin DeltaInSpace := TemplSpaceLengthBetwDefis - SrcSpaceLengthBetwDefis; for j := 0 to DeltaInSpace - 1 do Insert(FillCh, Result, SrcPos+1); SrcNewPos := SrcNewPos + DeltaInSpace; end; SrcPos := SrcNewPos; TemplSpaceLengthBetwDefis := 0; end else begin Inc(TemplSpaceLengthBetwDefis); end; end; } end; function GetLastCableCanalConnectorID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do Result := GenIDFromTable(Query_Select, gnCableCanalConnectorsID, 0); bkProjectManager: //with F_ProjMan.DM do // Result := FLastCableCanalConnectorID; Result := GenCurrProjTableID(giCableCanalConnectorsID, 0); end; end; function GetLastComponentID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select * from GET_LAST_COMPONENT_ID'); Result := scsQSelect.GetFNAsInteger(fnLastID); end; bkProjectManager: Result := GenCurrProjTableID(giComponentID, 0); //with F_ProjMan.DM do // Result := FLastComponentID; end; end; function GetLastInterfRelID(AGDBMode: TDBKind): Integer; //var MaxID: Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select * from GET_LAST_INTERF_REL_ID '); Result := scsQSelect.GetFNAsInteger('LASTID'); end; bkProjectManager: Result := GenCurrProjTableID(giInterfaceRelationID, 0); //with F_ProjMan.DM do // begin // Result := FLastInterfRelID; {try SetSQLToQuery(scsQSelect, ' select DISTINCT LASTAUTOINC(interface_relation, id) As Last_ID from interface_relation '); finally Result := scsQSelect.GetFNAsInteger('Last_ID'); end; } //SetSQLToQuery(scsQOperat, ' insert into interface_relation (id_component) values(0) '); //SetSQLToQuery(scsQSelect, ' select Max(ID) As Max_ID from interface_relation '); //MaxID := scsQSelect.GetFNAsInteger('Max_ID'); //SetSQLToQuery(scsQOperat, ' delete from interface_relation where id = '''+IntToStr(MaxID)+''' '); //Result := MaxID + 1; // end; end; end; function GetLastInterfOfInterfRelID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select * from GET_LAST_INTERFOFONTERF_REL_ID'); Result := scsQSelect.GetFNAsInteger('LASTID'); end; bkProjectManager: Result := GenCurrProjTableID(giInterfOfInterfRelationID, 0); //with F_ProjMan.DM do // Result := FLastInterfOfInterfRel; end; end; function GetLastCompRelID(AGDBMode: TDBKind): Integer; var MaxID: Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select * from GET_LAST_COMPLECT_ID '); Result := scsQSelect.GetFNAsInteger('LASTID'); end; bkProjectManager: Result := GenCurrProjTableID(giComponentRelationID, 0); //with F_ProjMan.DM do // begin // Result := FLastCompRelID; {try SetSQLToQuery(scsQSelect, ' select DISTINCT LASTAUTOINC(interface_relation, id) As Last_ID from interface_relation '); finally Result := scsQSelect.GetFNAsInteger('Last_ID'); end; } {SetSQLToQuery(scsQOperat, ' insert into component_relation (id_child) values(0) '); SetSQLToQuery(scsQSelect, ' select Max(ID) As Max_ID from component_relation '); MaxID := scsQSelect.GetFNAsInteger('Max_ID'); SetSQLToQuery(scsQOperat, ' delete from component_relation where id = '''+IntToStr(MaxID)+''' '); Result := MaxID; } // end; end; end; function GetLastCompPropRelID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do Result := GenIDFromTable(Query_Select, gnCompPropRelationID, 0); bkProjectManager: Result := GenCurrProjTableID(giCompPropRelationID, 0); //with F_ProjMan.DM do // Result := FLastComponPropRelID; end; end; function GetLastNormID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do Result := GenIDFromTable(Query_Select, gnGenNormsID, 0); bkProjectManager: Result := GenCurrProjTableID(giNormsID, 0); end; end; function GetLastNormResourceID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do Result := GenIDFromTable(Query_Select, gnNormResourceRelID, 0); bkProjectManager: Result := GenCurrProjTableID(giNormResourceRelID, 0); end; end; function GetLastPortInterfRelID(AGDBMode: TDBKind): Integer; begin Result := 0; case AGDBMode of bkNormBase: with F_NormBase.DM do Result := GenIDFromTable(Query_Select, gnPortInterfaceRelationID, 0); bkProjectManager: Result := GenCurrProjTableID(giPortInterfaceRelationID, 0); //with F_ProjMan.DM do // Result := FLastPortInterfRelID; end; end; function GetParallelSide(ASide: Integer): Integer; begin Result := 0; case ASide of stSide1: Result := stSide2; stSide2: Result := stSide1; end; end; function GetIsActiveFormProgress: Boolean; begin Result := false; if Assigned(F_Progress) then Result := F_Progress.Visible; end; procedure PauseProgress(APaused: Boolean); begin //if Assigned(FSCS_Main) then // if APaused then // SetCADsProgressMode(false); if Assigned(F_Progress) then begin F_Progress.PauseProgress(APaused); end; //if Assigned(FSCS_Main) then // if Not APaused then // SetCADsProgressMode(true); if Assigned(FSCS_Main) then SetCADsProgressMode(Not APaused); {if Assigned(F_Progress) then case APaused of true: begin Application.OnMessage := Nil; //F_Progress.Hide; end; false: begin Application.OnMessage := F_Progress.Action; if Not F_Progress.Visible or Not F_Progress.Showing then F_Progress.Show; F_Progress.Refresh; //if GetForegroundWindow <> F_Progress.Handle then // SetForegroundWindow(F_Progress.Handle); end; end;} end; procedure PauseProgressByMode(APaused: Boolean); begin If GIsProgress then PauseProgress(APaused); end; function GetIsLineByComponType(AComponType: TComponentType): Integer; begin Result := AComponType.IsLine; if AComponType.SysName = ctsnArhRoom then Result := ctArhRoom else if AComponType.SysName = ctsnArhWall then Result := ctArhWall else if AComponType.SysName = ctsnArhWallDivision then Result := ctArhWallDivision else if AComponType.SysName = ctsnArhFloor then Result := ctArhFloor else if AComponType.SysName = ctsnArhCeiling then Result := ctArhCeiling else if AComponType.SysName = ctsnArhEmbrasure then Result := ctArhEmbrasure else if AComponType.SysName = ctsnArhWindow then Result := ctArhWindow else if AComponType.SysName = ctsnArhDoor then Result := ctArhDoor else if AComponType.SysName = ctsnArhNiche then Result := ctArhNiche else if AComponType.SysName = ctsnArhInnerSlope then Result := ctArhInnerSlope else if AComponType.SysName = ctsnArhOuterSlope then Result := ctArhOuterSlope else if AComponType.SysName = ctsnArhArc then Result := ctArhArc else if AComponType.SysName = ctsnArhBalcony then Result := ctArhBalcony else if AComponType.SysName = ctsnArhBrickWall then Result := ctArhBrickWall else if AComponType.SysName = ctsnArhRoof then Result := ctArhRoof else if AComponType.SysName = ctsnArhRoofSeg then Result := ctArhRoofSeg else if AComponType.SysName = ctsnArhRoofHip then Result := ctArhRoofHip; end; function isLineCompon(AForm: TForm; AIDComponent: Integer): Boolean; var strFilter: String; SCSComponent: TSCSComponent; begin Result := false; strFilter := 'id = '''+IntToStr(AIDComponent)+''''; with TF_Main(AForm) do case GDBMode of bkNormBase: begin SetSQLToQuery(DM.scsQSelect, ' select isLine from Component where '+strFilter); if DM.scsQSelect.GetFNAsInteger('isLine') = 1 then Result := true; end; bkProjectManager: begin SCSComponent := GSCSBase.CurrProject.GetComponentFromReferences(AIDComponent); if Assigned(SCSComponent) then Result := IntToBool(SCSComponent.IsLine); //if DM.GetComponFieldValueAsInteger(AIDComponent, fnIsLine) = biTrue then // Result := true; end; end; //with TF_Main(AFormBase).DM do // begin //SetSQLToQuery(TSCSQuery(AQuery), ' select isLine from Component where id = '''+IntToStr(AIDComponent)+''' '); //if TSCSQuery(AQuery).GetFNAsInteger('isLine') = 1 then // Result := true; // end; end; function IsArchComponByIsLine(AIsLine: Integer): Boolean; begin Result := false; case AIsLine of ctArhRoom, ctArhWall, ctArhWallDivision, ctArhFloor, ctArhCeiling, ctArhEmbrasure, ctArhWindow, ctArhDoor, ctArhNiche, ctArhInnerSlope, ctArhOuterSlope, ctArhArc, ctArhBalcony, ctArhBrickWall, ctArhWallCorner, ctArhRoof, ctArhRoofSeg, ctArhRoofHip, ctArhRoofHipCorner: Result := true; end; end; function IsArchComponByItemType(AItemType: Integer): Boolean; begin Result := false; case AItemType of itArhRoom, itArhWall, itArhWallDivision, itArhFloor, itArhCeiling, itArhEmbrasure, itArhWindow, itArhDoor, itArhNiche, itArhInnerSlope, itArhOuterSlope, itArhArc, itArhBalcony, itArhBrickWall, itArhWallCorner, itArhRoof, itArhRoofSeg, itArhRoofHip, itArhRoofHipCorner: Result := true; end; end; function IsArchCornerComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhWallCorner) or (AIsLine = ctArhRoofHipCorner); end; function IsArchBalconyChildComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhWindow) or (AIsLine = ctArhDoor) or IsSlopeComponByIsLine(AIsLine); end; function IsArchRoomComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhRoom) or (AIsLine = ctArhBrickWall); end; function IsArchTopComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhRoom) or (AIsLine = ctArhBrickWall) or (AIsLine = ctArhRoofSeg); end; function IsArchSegmentComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhWall) or (AIsLine = ctArhWallDivision) or (AIsLine = ctArhRoofHip); end; function IsArchSegmentIn3DByIsLine(AIsLine: Integer): Boolean; begin Result := AIsLine = ctArhRoofSeg; end; function IsArchFrameSegmentComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhWall) or (AIsLine = ctArhRoofHip); end; function IsArchWallChildComponByIsLine(AIsLine: Integer): Boolean; begin Result := (AIsLine = ctArhWindow) or (AIsLine = ctArhDoor) or (AIsLine = ctArhNiche) or (AIsLine = ctArhArc) or (AIsLine = ctArhBalcony); end; function IsSlopeComponByIsLine(AIsLine: Integer): Boolean; begin Result := false; case AIsLine of ctArhInnerSlope, ctArhOuterSlope: Result := true; end; end; function IsProperItemTypeToIsLine(AItemType, AIsLine: Integer): Boolean; begin Result := false; case AItemType of itLinkCompCon: if AIsLine = ctConn then Result := true; itLinkCompLine: if AIsLine = ctLine then Result := true; else begin if AItemType = GetItemTypeByIsLine(AIsLine) then Result := true; end; end; //case AItemType of // itComponCon, itLinkCompCon: // if AIsLine = ctConn then // Result := true; // itComponLine, itLinkCompLine: // if AIsLine = ctLine then // Result := true; // itArhRoom: // if AIsLine = ctArhRoom then // Result := true; // itArhWall: // if AIsLine = ctArhWall then // Result := true; // itArhWallDivision: // if AIsLine = ctArhWallDivision then // Result := true; // itArhFloor: // if AIsLine = ctArhFloor then // Result := true; // itArhCeiling: // if AIsLine = ctArhCeiling then // Result := true; // itArhEmbrasure: // if AIsLine = ctArhEmbrasure then // Result := true; // itArhWindow: // if AIsLine = ctArhWindow then // Result := true; // itArhDoor: // if AIsLine = ctArhDoor then // Result := true; // itArhNiche: // if AIsLine = ctArhNiche then // Result := true; // itArhInnerSlope: // if AIsLine = ctArhInnerSlope then // Result := true; // itArhOuterSlope: // if AIsLine = ctArhOuterSlope then // Result := true; // itArhArc: // if AIsLine = ctArhArc then // Result := true; // itArhBalcony: // if AIsLine = ctArhBalcony then // Result := true; // itArhBrickWall: // if AIsLine = ctArhBrickWall then // Result := true; // end; end; function HaveComponFunctionalInterfaces(AQuery: TObject; AIDComponent: Integer): Boolean; begin Result := false; try SetSQLToQuery(TSCSQuery(AQuery), ' select count(id) As Cnt from interface_relation '+ ' where (id_component = '''+IntToStr(AIDComponent)+''') and '+ ' (typei = '''+IntToStr(itFunctional)+''') '); if TSCSQuery(AQuery).GetFNAsInteger('Cnt') > 0 then Result := true; except on E: Exception do AddExceptionToLog('HaveComponFunctionalInterfaces: '+E.Message); end; end; function GetItemTypeByIsLine(AIsLine: Integer): Integer; begin Result := itNone; case AIsLine of ctLine: Result := itComponLine; ctConn: Result := itComponCon; ctArhRoom: Result := itArhRoom; ctArhWall: Result := itArhWall; ctArhWallDivision: Result := itArhWallDivision; ctArhFloor: Result := itArhFloor; ctArhCeiling: Result := itArhCeiling; ctArhEmbrasure: Result := itArhEmbrasure; ctArhWindow: Result := itArhWindow; ctArhDoor: Result := itArhDoor; ctArhNiche: Result := itArhNiche; ctArhInnerSlope: Result := itArhInnerSlope; ctArhOuterSlope: Result := itArhOuterSlope; ctArhArc: Result := itArhArc; ctArhBalcony: Result := itArhBalcony; ctArhBrickWall: Result := itArhBrickWall; ctArhWallCorner: Result := itArhWallCorner; ctArhRoof: Result := itArhRoof; ctArhRoofSeg: Result := itArhRoofSeg; ctArhRoofHip: Result := itArhRoofHip; ctArhRoofHipCorner: Result := itArhRoofHipCorner; end; end; // ##### Вернет список ID-в всех компонентов папки ##### function GetFolderComponList(AFormBase: TForm; AFolder: TObject; AObjectTypes: TIntSet): TList; var ResList: TList; SCSFolder: TSCSCatalog; ChildFolder: TSCSCatalog; SCSComponent: TSCSComponent; GDBMode: TDBKind; i, j: Integer; ptrID: ^Integer; { procedure FillFolderComponList(AIDRoot: Integer); var ChildFolders: TList; i: Integer; CurrCatalog: TSCSCatalog; SCSComponent: TSCSComponent; ptrNewID: ^Integer; begin CurrCatalog := nil; if GDBMode = bkNormBase then begin CurrCatalog := TSCSCatalog.Create(AFormBase); CurrCatalog.LoadCatalogByID(AIDRoot, false); end else CurrCatalog := TF_Main(AFormBase).GSCSBase.CurrProject.GetCatalogFromReferences(AIDRoot); if Assigned(CurrCatalog) then begin if ((CurrCatalog.ItemType = itSCSConnector) and (CurrCatalog.KolCompon > 0) and (itSCSConnector in AObjectTypes)) or ((CurrCatalog.ItemType = itSCSLine) and (CurrCatalog.KolCompon > 0) and (itSCSLine in AObjectTypes)) or Not(CurrCatalog.ItemType in [itSCSConnector, itSCSLine]) then begin if GDBMode = bkNormBase then begin CurrCatalog.LoadAllComponents(AIDRoot, false); for i := 0 to CurrCatalog.SCSComponents.Count - 1 do begin SCSComponent := CurrCatalog.SCSComponents.Items[i]; //New(ptrNewID); GetMem(ptrNewID, SizeOf(Integer)); ptrNewID^ := SCSComponent.ID; ResList.Add(ptrNewID); end; end else for i := 0 to CurrCatalog.ComponentReferences.Count - 1 do begin SCSComponent := CurrCatalog.ComponentReferences.Items[i]; //New(ptrNewID); GetMem(ptrNewID, SizeOf(Integer)); ptrNewID^ := SCSComponent.ID; ResList.Add(ptrNewID); end; //ChildFolders := TList.Create; with TF_Main(AFormBase).DM do begin //SetSQLToQuery(scsQSelect, ' select id from katalog where parent_id = '''+IntToStr(AIDRoot)+''' '); //IntFieldToList(ChildFolders, scsQSelect, 'ID'); ChildFolders := GetCatalogChildsID(AIDRoot, GetQueryModeByGDBMode(GDBMode)); for i := 0 to ChildFolders.Count - 1 do FillFolderComponList(Integer(ChildFolders.Items[i]^)); end; FreeList(ChildFolders); end; if GDBMode = bkNormBase then FreeAndNil(CurrCatalog); end; end; } begin Result := nil; try if Assigned(AFolder) then begin SCSFolder := TSCSCatalog(AFolder); ResList := TList.Create; GDBMode := TF_Main(AFormBase).GDBMode; //FillFolderComponList(AIDCatalog); for i := 0 to SCSFolder.ChildCatalogReferences.Count - 1 do begin ChildFolder := SCSFolder.ChildCatalogReferences[i]; if Assigned(ChildFolder) then if ((ChildFolder.ItemType = itSCSConnector) and (itSCSConnector in AObjectTypes)) or ((ChildFolder.ItemType = itSCSLine) and (itSCSLine in AObjectTypes)) then for j := 0 to ChildFolder.ComponentReferences.Count - 1 do begin SCSComponent := ChildFolder.ComponentReferences[j]; if Assigned(SCSComponent) then begin GetMem(ptrID, SizeOf(Integer)); ptrID^ := SCSComponent.ID; ResList.Add(ptrID); end; end; end; if ResList.Count = 0 then ResList.Free else Result := ResList; end; except on E: Exception do AddExceptionToLog('GetFolderComponList: '+E.Message); end; end; // ##### Обновит длины линейных компонентов Листа ##### procedure RefreshComponsLengthByList(AIDList: Integer); var {FolderIDComponList: TList; ListWithLookedCompons: TList; CatalogList: TSCSList; IDList: Integer; Component: TSCSComponent; i, j: Integer; ptrID: ^Integer; } SCSList: TSCSList; SCSLineComponent: TSCSComponent; PartComponent: TSCSComponent; i, j: Integer; LookedComponents: TSCSComponents; begin try SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if Assigned(SCSList) then begin LookedComponents := TSCSComponents.Create(false); for i := 0 to SCSList.ComponentReferences.Count - 1 do begin SCSLineComponent := SCSList.ComponentReferences[i]; if SCSLineComponent.IsLine = biTrue then if LookedComponents.IndexOf(SCSLineComponent) = -1 then begin SCSLineComponent.LoadWholeComponent(false); SCSLineComponent.RefreshWholeLengthInFuture; for j := 0 to SCSLineComponent.WholeComponent.Count - 1 do begin PartComponent := SCSList.GetComponentFromReferences(SCSLineComponent.WholeComponent[j]); if PartComponent <> nil then LookedComponents.Add(PartComponent); end; end; end; LookedComponents.Free; end; { CatalogList := nil; IDList := F_ProjMan.DM.GetIDListByIDCatalog(AIDListCatalog); CatalogList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(IDList); if Assigned(CatalogList) then begin ListWithLookedCompons := TList.Create; for i := 0 to CatalogList.ComponentReferences.Count - 1 do if Assigned(CatalogList.ComponentReferences[i]) then if CatalogList.ComponentReferences[i].IsLine = biTrue then if CheckNoIDinList(CatalogList.ComponentReferences[i].ID, ListWithLookedCompons) then begin Component := CatalogList.ComponentReferences[i]; if Assigned(Component) then begin Component.LoadWholeComponent(false); //Component.LoadWholeLength(true); Component.RefreshWholeLength; for j := 0 to Component.WholeComponent.Count - 1 do begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := Integer(Component.WholeComponent[j]^); ListWithLookedCompons.Add(ptrID); end; end; end; FreeList(ListWithLookedCompons); end; } {//FolderIDComponList := Tlist.Create; FolderIDComponList := nil; ListWithLookedCompons := TList.Create; Component := nil; Component := TSCSComponent.Create(TForm(F_ProjMan)); FolderIDComponList := GetFolderComponList(TForm(F_ProjMan), AIDListCatalog, [itSCSLine]); try //*** Найти все кмопоненты папки if FolderIDComponList = nil then Exit; //// EXIT ///// for i := 0 to FolderIDComponList.Count - 1 do begin if CheckNoIDinList(Integer(FolderIDComponList[i]^), ListWithLookedCompons) then begin Component.LoadComponentByID(Integer(FolderIDComponList[i]^), false); if Component.IsLine = biTrue then begin Component.LoadWholeComponent(false); Component.LoadWholeLength(true); Component.RefreshWholeLength; for j := 0 to Component.WholeComponent.Count - 1 do begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := Integer(Component.WholeComponent[j]^); ListWithLookedCompons.Add(ptrID); end; end; end; end; finally FreeList(ListWithLookedCompons); FreeList(FolderIDComponList); if Component <> nil then Component.Free; end; } except on E: Exception do AddExceptionToLog('RefreshComponsLengthByList: '+E.Message); end; end; // ##### Обновить маркировки ##### procedure RefreshComponMarks(AIDParentCatalog: Integer); var Component: TSCSComponent; ComponentObject: TSCSCatalog; i, j: Integer; tempstr: string; begin try //FolderIDComponList := Tlist.Create; with F_ProjMan do if GSCSBase.CurrProject.Active then for i := 0 to GSCSBase.CurrProject.ComponentReferences.Count - 1 do begin Component := GSCSBase.CurrProject.ComponentReferences[i]; if Assigned(Component) then begin ComponentObject := Component.GetFirstParentCatalog; if Assigned(ComponentObject) then begin Component.NameMark := F_ProjMan.MakeNameMarkComponent(Component, ComponentObject, true); end; end; end; except on E: Exception do AddExceptionToLog('RefreshComponMarks: '+E.Message); end; end; { procedure RefreshComponMarks(AIDParentCatalog: Integer); var FolderIDComponList: TList; ListWithLookedCompons: TList; Component: TSCSComponent; i, j: Integer; ptrID: ^Integer; tempstr: string; begin try //FolderIDComponList := Tlist.Create; FolderIDComponList := nil; ListWithLookedCompons := TList.Create; Component := nil; Component := TSCSComponent.Create(TForm(F_ProjMan)); FolderIDComponList := GetFolderComponList(TForm(F_ProjMan), AIDParentCatalog, [itSCSLine, itSCSConnector]); try //*** Найти все кмопоненты папки if FolderIDComponList = nil then Exit; //// EXIT ///// for i := 0 to FolderIDComponList.Count - 1 do begin if CheckNoIDinList(Integer(FolderIDComponList[i]^), ListWithLookedCompons) then begin Component.LoadComponentByID(Integer(FolderIDComponList[i]^), false); //if Component.IsLine = biFalse then begin Component.LoadOwnerCatalog(false); tempstr := F_ProjMan.MakeNameMarkComponent(Component, TSCSCatalog(Component.OwnerCatalog), true); //for j := 0 to Component.WholeComponent.Count - 1 do // begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := Component.ID; ListWithLookedCompons.Add(ptrID); // end; end; end; end; finally FreeList(ListWithLookedCompons); FreeList(FolderIDComponList); if Component <> nil then FreeAndNil(Component); end; except on E: Exception do AddExceptionToLog('RefreshComponMarks: '+E.Message); end; end; } // ##### Обновляет Стили Отображения трасс ##### procedure RefreshListItems(AListID: Integer; AItemTypes: Integer; AForSelected: Boolean); var List: TSCSList; i: Integer; SCSObject: TSCSCatalog; begin if AItemTypes = rltNone then Exit; ///// EXIT ///// List := nil; //List := TSCSList.Create(F_ProjMan); //try with F_ProjMan do begin if GSCSBase.CurrProject.Active then List := GSCSBase.CurrProject.GetListBySCSID(AListID); end; if Assigned(List) then try //List.Open(AListID); //List.CurrID := AListID; //List.LoadChildCatalogs(false); for i := 0 to List.ChildCatalogReferences.Count - 1 do if Assigned(List.ChildCatalogReferences[i]) then begin SCSObject := List.ChildCatalogReferences[i]; if (AForSelected = false) or CheckCADObjectSelect(SCSObject.ListID, SCSObject.SCSID) then begin if SCSObject.ItemType = itSCSLine then begin if rltTracessStyle and AItemTypes = rltTracessStyle then F_ProjMan.F_ChoiceConnectSide.DefineTraceStyleInCAD(SCSObject); if rltTracessFulness and AItemTypes = rltTracessFulness then F_ProjMan.F_ChoiceConnectSide.DefineObjectStatus(SCSObject); //begin //SCSTrace.LoadComponents(SCSTrace.ID, false); //if SCSTrace.SCSComponents.Count > 0 then //F_ProjMan.F_ChoiceConnectSide.DefineObjectFullness(TSCSComponent(SCSTrace.SCSComponents[0])); //end; end; if rltCADSignature and AItemTypes = rltCADSignature then F_ProjMan.F_ChoiceConnectSide.DefineObjectSignature(SCSObject); if rltNote and AItemTypes = rltNote then F_ProjMan.F_ChoiceConnectSide.DefineObjectNote(SCSObject); if rltTracessStyle and AItemTypes = rltTracessStyle then F_ProjMan.F_ChoiceConnectSide.DefineTraceStyleInCAD(SCSObject); end; end; RefreshAllLists; except on E: Exception do AddExceptionToLog('RefreshListItems: '+E.Message); end; //finally // FreeAndNil(List); //end; end; function GetJoinedAllLinesToPointCompon(AIDPointComponent: Integer; APointComponent: TObject): TObject; var PointComponent: TSCSComponent; LinesCompons: TSCSComponents; i: Integer; ptrID: ^Integer; procedure Step(AComponent: TSCSComponent); var i: Integer; begin if Assigned(AComponent) then begin if AComponent.IsLine = biTrue then if LinesCompons.IndexOf(AComponent) = -1 then begin LinesCompons.Add(AComponent); for i := 0 to AComponent.JoinedComponents.Count - 1 do if Assigned(AComponent.JoinedComponents[i]) then Step(AComponent.JoinedComponents[i]); end; end; end; begin Result := nil; PointComponent := nil; if APointComponent = nil then PointComponent := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDPointComponent) else PointComponent := TSCSComponent(APointComponent); if Assigned(PointComponent) then begin LinesCompons := TSCSComponents.Create(false); for i := 0 to PointComponent.JoinedComponents.Count - 1 do if Assigned(PointComponent.JoinedComponents[i]) then Step(PointComponent.JoinedComponents[i]); Result := LinesCompons; {Result := TList.Create; for i := 0 to LinesCompons.Count - 1 do begin GetMem(ptrID, SizeOf(Integer)); ptrID^ := LinesCompons[i].ID; Result.Add(ptrID); end;} //LinesCompons.Free; end; end; function GetNetFromComponenet(AComponent: TObject; const AGUIDNetTypeJoinedToPoint: String; ATakeIntoAutoTracing: Boolean): TList; var i: Integer; ResList: TList; IDAutoTracingPropertyStr: String; LineSideAtFirstConnCompon: Integer; //*************** ComponFromParam: TSCSComponent; PathLineCompons: TSCSComponents; FirstLineComponent: TSCSComponent; FirstConnCompons: TSCSComponents; LastConnCompons: TSCSComponents; InOrder: TSCSComponents; PathLineComponsRes: TSCSComponents; FirstConnComponsRes: TSCSComponents; LastConnComponsRes: TSCSComponents; ptrJoinedComponents: PJoinedComponents; JoinedLineComponent: TSCSComponent; function DefineFirstComponent(ALineComponent: TSCSComponent; AInOrder: TSCSComponents): Boolean; var i: Integer; JoinedComponents: TSCSComponents; JoinedComponent: TSCSComponent; LineSideAtPoinComponent: Integer; begin Result := false; if Assigned(ALineComponent) then if ALineComponent.isLine = biTrue then begin FirstLineComponent := ALineComponent; JoinedComponents := TSCSComponents.Create(false); JoinedComponents.Assign(ALineComponent.JoinedComponents); for i := 0 to JoinedComponents.Count - 1 do begin JoinedComponent := JoinedComponents[i]; if AInOrder.IndexOf(JoinedComponent) = -1 then begin if JoinedComponent.IsLine = biFalse then begin //*** Если уже найден первый точ компонент, то JoinedComponent будет в этом же списке, // если он с той же стороны, что и FirstConnCompons[0], или не подкл-н к ALineComponent if (FirstConnCompons.Count > 0) then begin //*** Если сторона трассы покл-я к точ. компоненту не известная if LineSideAtFirstConnCompon = -1 then LineSideAtFirstConnCompon := GetComponSideJoinedToCompon(ALineComponent, FirstConnCompons[0]); //*** Если Стороны не одинаковые, то пропускаем добавление if LineSideAtFirstConnCompon <> -1 then begin LineSideAtPoinComponent := GetComponSideJoinedToCompon(ALineComponent, JoinedComponent); if LineSideAtFirstConnCompon <> LineSideAtPoinComponent then Continue; //// CONTINUE //// end; end; Result := true; FirstConnCompons.Add(JoinedComponents[i]); end else if Result = false then begin AInOrder.Assign(JoinedComponents, LaOr); Result := DefineFirstComponent(JoinedComponents[i], AInOrder); //AInOrder.Assign(JoinedComponents, laXor); end; end; end; FreeAndNil(JoinedComponents); end; end; procedure DefineJoined(ALineComponent: TSCSComponent; AInOrder: TSCSComponents); var i: Integer; JoinedComponents: TSCSComponents; JoinedNoLine: Boolean; JoinedCount: Integer; begin JoinedNoLine := false; JoinedCount := 0; if Assigned(ALineComponent) then if ALineComponent.isLine = biTrue then begin PathLineCompons.Add(ALineComponent); JoinedComponents := TSCSComponents.Create(false); JoinedComponents.Assign(ALineComponent.JoinedComponents); for i := 0 to AInOrder.Count - 1 do JoinedComponents.Remove(AInOrder[i]); for i := 0 to JoinedComponents.Count - 1 do if AInOrder.IndexOf(JoinedComponents[i]) = -1 then begin if JoinedComponents[i].IsLine = biFalse then begin JoinedNoLine := true; LastConnCompons.Add(JoinedComponents[i]); end else if JoinedNoLine = false then begin AInOrder.Assign(JoinedComponents, LaOr); DefineJoined(JoinedComponents[i], AInOrder); AInOrder.Assign(JoinedComponents, laXor); Inc(JoinedCount); end; end; FreeAndNil(JoinedComponents); if (JoinedNoLine) or (JoinedCount = 0) then begin GetMem(ptrJoinedComponents, SizeOf(TJoinedComponents)); PathLineComponsRes := TSCSComponents.Create(false); FirstConnComponsRes := TSCSComponents.Create(false); LastConnComponsRes := TSCSComponents.Create(false); PathLineComponsRes.Assign(PathLineCompons); FirstConnComponsRes.Assign(FirstConnCompons); LastConnComponsRes.Assign(LastConnCompons); ptrJoinedComponents.JoinedLines := PathLineComponsRes; ptrJoinedComponents.First := FirstLineComponent; ptrJoinedComponents.Last := ALineComponent; ptrJoinedComponents.FirstConnCompons := FirstConnComponsRes; ptrJoinedComponents.LastConnCompons := LastConnComponsRes; ResList.Add(ptrJoinedComponents); LastConnCompons.Clear; end; PathLineCompons.Remove(ALineComponent); end; end; begin Result := nil; ResList := TList.Create; //*** Найти ID свойства авторокладки //with F_NormBase.DM do // begin // SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); // IDAutoTracingPropertyStr := IntToStr(scsQSelect.GetFNAsInteger('id')); // end; ComponFromParam := TSCSComponent(AComponent); FirstLineComponent := nil; LineSideAtFirstConnCompon := -1; //FirstLineComponent := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDLineCompon); if Assigned(ComponFromParam) then begin FirstConnCompons := TSCSComponents.Create(false); LastConnCompons := TSCSComponents.Create(false); PathLineCompons := TSCSComponents.Create(false); InOrder := TSCSComponents.Create(false); case ComponFromParam.IsLine of biTrue: begin FirstLineComponent := ComponFromParam; //*** Выйти на крайний компонент InOrder.Add(FirstLineComponent); DefineFirstComponent(FirstLineComponent, InOrder); InOrder.Clear; InOrder.Add(FirstLineComponent); InOrder.Assign(FirstConnCompons, laOr); DefineJoined(FirstLineComponent, InOrder); //ListWithLooked := Tlist.Create; //FreeList(ListWithLooked); end; biFalse: begin FirstConnCompons.Add(ComponFromParam); for i := 0 to ComponFromParam.JoinedComponents.Count - 1 do begin JoinedLineComponent := ComponFromParam.JoinedComponents[i]; if JoinedLineComponent.IsLine = biTrue then if (AGUIDNetTypeJoinedToPoint = '') or (JoinedLineComponent.GUIDNetType = AGUIDNetTypeJoinedToPoint) then begin FirstLineComponent := JoinedLineComponent; LastConnCompons.Clear; PathLineCompons.Clear; InOrder.Clear; InOrder.Add(ComponFromParam); InOrder.Add(FirstLineComponent); DefineJoined(FirstLineComponent, InOrder); end; end; end; end; FreeAndNil(InOrder); FreeAndNil(PathLineCompons); FreeAndNil(LastConnCompons); FreeAndNil(FirstConnCompons); end; Result := ResList; end; // ##### Вернет список ID-в компонент на всей трассе с помощу рекурсии ##### function GetLineComponsInTrace(AIDComponent: Integer; AObjComponent: TObject): TWholeLineCompon; var SourceCompon: TSCSComponent; //ResList: TList; IDPathList: TIntList; ObjPathList: TSCSComponents; IDAutoTracingPropertyStr: String; //ptrIDCompon: ^Integer; NullBool: Boolean; //FirstIDConnNoLineCompon: Integer; //LastIDConnNoLineCompon: Integer; FirstConnNoLineCompon: TSCSComponent; LastConnNoLineCompon: TSCSComponent; FirstConnNoLineObject: TSCSCatalog; FirstID, FirstSide: Integer; FirstCompon: TSCSComponent; LastID, LastSide, LastIdx: Integer; LastCompon: TSCSComponent; procedure Step(ASourceCompon, APrevSrcCompon: TSCSComponent; AInOrder: TSCSComponents; ATraveledIndex: Integer; var AWasNoLine: Boolean); var i: Integer; WasCabling: Boolean; WasRecurse: Boolean; WasNoLineCompon: Boolean; JoinedComponent: TSCSComponent; begin WasRecurse := false; if Not Assigned(SourceCompon) then Exit; //// EXIT //// if Not(ASourceCompon.IsLine = biTrue) then begin //if FirstIDConnNoLineCompon = 0 then // FirstIDConnNoLineCompon := ASourceCompon.ID; //else //if LastIDConnNoLineCompon = 0 then // LastIDConnNoLineCompon := ASourceCompon.ID; if FirstConnNoLineCompon = nil then begin FirstConnNoLineCompon := ASourceCompon; FirstConnNoLineObject := FirstConnNoLineCompon.GetFirstParentCatalog; if APrevSrcCompon <> nil then begin FirstID := APrevSrcCompon.ID; FirstCompon := APrevSrcCompon; FirstSide := GetComponSideJoinedToComponByInterf(APrevSrcCompon, ASourceCompon); end; end else if LastConnNoLineCompon = nil then begin //28.01.2011 Решено позволить использовать один объект как конечный и начальный //28.01.2011 поскольку бывают случаи когда трассами соединены подъезды одного дома между собой //28.01.2011 или два кросса одного АТС //28.01.2011 if ASourceCompon.GetFirstParentCatalog <> FirstConnNoLineObject then // конечные компоненты должны быть в разных объектах //24.10.2011 LastConnNoLineCompon := ASourceCompon; if APrevSrcCompon <> nil then begin LastSide := GetComponSideJoinedToComponByInterf(APrevSrcCompon, ASourceCompon); // Если с этой стороны добавлен этот же линейный компонент, то пропускаем это соединение if (LastSide = FirstSide) and (APrevSrcCompon = FirstCompon) then LastSide := 0 else begin LastID := APrevSrcCompon.ID; LastCompon := APrevSrcCompon; LastConnNoLineCompon := ASourceCompon; end; end; end; AWasNoLine := true; Exit; ///// EXIT ///// end else AWasNoLine := false; WasCabling := false; //*** Проверка на скрутки //24.10.2011 if GetJoinedLineComponCount(ASourceCompon) > 2 then //if (ASourceCompon.JoinedComponents.Count > 2) then //24.10.2011 WasCabling := true; //if Not WasCabling then try begin IDPathList.Add(ASourceCompon.ID); ObjPathList.Add(ASourceCompon); for i := 0 to ASourceCompon.JoinedComponents.Count - 1 do begin JoinedComponent := ASourceCompon.JoinedComponents[i]; if JoinedComponent <> nil then // Tolik 01/04/2020 -- begin if Not WasCabling or (JoinedComponent.IsLine = biFalse) then if ((AInOrder = nil) or (AInOrder.IndexOf(JoinedComponent) = -1)) and (IDPathList.IndexOf(JoinedComponent.ID) = -1) then //if CheckNoIDinList(IDConn, AInOrder)and // CheckNoIDinList(IDConn, IDPathList) then begin //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laOr); Step(JoinedComponent, ASourceCompon, ASourceCompon.JoinedComponents, ATraveledIndex + 1, WasNoLineCompon); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laXor); //24.10.2011 WasRecurse := true; end; end; end; end; except on E: Exception do ShowMessage('Step'); end; end; {//24.10.2011 procedure Step(ASourceCompon: TSCSComponent; AInOrder: TSCSComponents; ATraveledIndex: Integer; var AWasNoLine: Boolean); var i: Integer; WasCabling: Boolean; WasRecurse: Boolean; WasNoLineCompon: Boolean; JoinedComponent: TSCSComponent; begin WasRecurse := false; if Not Assigned(SourceCompon) then Exit; //// EXIT //// if Not(ASourceCompon.IsLine = biTrue) then begin //if FirstIDConnNoLineCompon = 0 then // FirstIDConnNoLineCompon := ASourceCompon.ID; //else //if LastIDConnNoLineCompon = 0 then // LastIDConnNoLineCompon := ASourceCompon.ID; if FirstConnNoLineCompon = nil then begin FirstConnNoLineCompon := ASourceCompon; FirstConnNoLineObject := FirstConnNoLineCompon.GetFirstParentCatalog; end else if LastConnNoLineCompon = nil then //28.01.2011 Решено позволить использовать один объект как конечный и начальный //28.01.2011 поскольку бывают случаи когда трассами соединены подъезды одного дома между собой //28.01.2011 или два кросса одного АТС //28.01.2011 if ASourceCompon.GetFirstParentCatalog <> FirstConnNoLineObject then // конечные компоненты должны быть в разных объектах LastConnNoLineCompon := ASourceCompon; AWasNoLine := true; Exit; ///// EXIT ///// end else AWasNoLine := false; WasCabling := false; //*** Проверка на скрутки if GetJoinedLineComponCount(ASourceCompon) > 2 then //if (ASourceCompon.JoinedComponents.Count > 2) then WasCabling := true; //if Not WasCabling then begin IDPathList.Add(ASourceCompon.ID); ObjPathList.Add(ASourceCompon); for i := 0 to ASourceCompon.JoinedComponents.Count - 1 do begin JoinedComponent := ASourceCompon.JoinedComponents[i]; if Not WasCabling or (JoinedComponent.IsLine = biFalse) then if ((AInOrder = nil) or (AInOrder.IndexOf(JoinedComponent) = -1)) and (IDPathList.IndexOf(JoinedComponent.ID) = -1) then //if CheckNoIDinList(IDConn, AInOrder)and // CheckNoIDinList(IDConn, IDPathList) then begin //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laOr); Step(JoinedComponent, ASourceCompon.JoinedComponents, ATraveledIndex + 1, WasNoLineCompon); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laXor); WasRecurse := true; end; end; end; if Not WasRecurse or WasNoLineCompon then begin if FirstID = 0 then begin FirstID := ASourceCompon.ID; FirstCompon := ASourceCompon; end else if LastID = 0 then begin LastID := ASourceCompon.ID; LastCompon := ASourceCompon; end; end; end; } { procedure Step(ASourceCompon: TSCSComponent; AInOrder: TSCSComponents; ATraveledIndex: Integer; var AWasNoLine: Boolean); var i: Integer; WasCabling: Boolean; WasRecurse: Boolean; WasNoLineCompon: Boolean; JoinedComponent: TSCSComponent; begin WasRecurse := false; if Not Assigned(SourceCompon) then Exit; //// EXIT //// if Not(ASourceCompon.IsLine = biTrue) then begin if FirstIDConnNoLineCompon = 0 then FirstIDConnNoLineCompon := ASourceCompon.ID else if LastIDConnNoLineCompon = 0 then LastIDConnNoLineCompon := ASourceCompon.ID; AWasNoLine := true; Exit; ///// EXIT ///// end else AWasNoLine := false; WasCabling := false; //*** Проверка на скрутки if (ASourceCompon.JoinedComponents.Count > 2) and (AInOrder <> nil) then if AInOrder.Count > 2 then WasCabling := true; if Not WasCabling then begin IDPathList.Add(ASourceCompon.ID); for i := 0 to ASourceCompon.JoinedComponents.Count - 1 do begin JoinedComponent := ASourceCompon.JoinedComponents[i]; if ((AInOrder = nil) or (AInOrder.IndexOf(JoinedComponent) = -1)) and (IDPathList.IndexOf(JoinedComponent.ID) = -1) then //if CheckNoIDinList(IDConn, AInOrder)and // CheckNoIDinList(IDConn, IDPathList) then begin //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laOr); Step(JoinedComponent, ASourceCompon.JoinedComponents, ATraveledIndex + 1, WasNoLineCompon); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laXor); WasRecurse := true; end; end; end; if Not WasRecurse or WasNoLineCompon then begin if FirstID = 0 then FirstID := ASourceCompon.ID else if LastID = 0 then LastID := ASourceCompon.ID; end; end; } begin try Result.WholeCompon := nil; Result.WholeComponObj := nil; Result.FirstIDCompon := 0; Result.FirstCompon := nil; Result.LastIDCompon := 0; Result.LastCompon := nil; Result.FirstIDConnectedConnCompon := 0; Result.FirstConnectedConnCompon := nil; Result.LastIDConnectedConnCompon := 0; Result.LastConnectedConnCompon := nil; IDPathList := TIntList.Create; ObjPathList := TSCSComponents.Create(false); //*** Найти ID свойства авторокладки //with F_NormBase.DM do // begin // SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); // IDAutoTracingPropertyStr := IntToStr(scsQSelect.GetFNAsInteger('id')); // end; //IDAutoTracingPropertyStr := IntToStr(piAutotracing); //FirstIDConnNoLineCompon := 0; //LastIDConnNoLineCompon := 0; FirstConnNoLineCompon := nil; LastConnNoLineCompon := nil; FirstConnNoLineObject := nil; FirstID := 0; FirstSide := 0; FirstCompon := nil; LastID := 0; LastSide := 0; LastCompon := nil; SourceCompon := nil; if AObjComponent = nil then SourceCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDComponent) else SourceCompon := TSCSComponent(AObjComponent); if SourceCompon <> nil then begin NullBool := false; Step(SourceCompon, nil, nil, 0, NullBool); //24.10.2011 Step(SourceCompon, nil, 0, NullBool); if IDPathList.Count > 0 then begin if FirstID = 0 then begin FirstID := AIDComponent; FirstCompon := SourceCompon; end; if LastID = 0 then begin LastID := AIDComponent; LastCompon := SourceCompon; if IDPathList.Count > 0 then begin LastIdx := -1; if IDPathList[IDPathList.Count-1] <> FirstID then LastIdx := IDPathList.Count-1 else if IDPathList[0] <> FirstID then LastIdx := 0; if LastIdx <> -1 then begin LastID := IDPathList[LastIdx]; LastCompon := ObjPathList[LastIdx]; end; end; end; Result.WholeCompon := IDPathList; Result.WholeComponObj := ObjPathList; Result.FirstIDCompon := FirstID; Result.FirstCompon := FirstCompon; Result.LastIDCompon := LastID; Result.LastCompon := LastCompon; //Result.FirstIDConnectedConnCompon := FirstIDConnNoLineCompon; //Result.LastIDConnectedConnCompon := LastIDConnNoLineCompon; if FirstConnNoLineCompon <> nil then begin Result.FirstIDConnectedConnCompon := FirstConnNoLineCompon.ID; Result.FirstConnectedConnCompon := FirstConnNoLineCompon; end; if LastConnNoLineCompon <> nil then begin Result.LastIDConnectedConnCompon := LastConnNoLineCompon.ID; Result.LastConnectedConnCompon := LastConnNoLineCompon; end; end else FreeAndNil(IDPathList); end; except on E: Exception do AddExceptionToLog('GetComponsInTrace: '+E.Message + 'AIdComponent = '+inttostr(AIdComponent)); end; end; // ##### Вернет список ID-в компонент на всей трассе с базы ##### function GetLineComponsInTraceFromBase(ALineComponent: TObject; ALoadComponIDs: Boolean): TWholeLineCompon; var ResList: TIntList; //IDWholeCompon: Integer; LineCompon: TSCSComponent; SCSComponents: TSCSComponents; PartCompon: TSCSComponent; //ptrID: ^Integer; i: Integer; ConnectedComponsInfo: TList; ptrConnectedComponsInfo: PConnectedComponsInfo; WasFrom: Boolean; WasTo: Boolean; begin Result.WholeCompon := nil; Result.WholeComponObj := nil; Result.FirstIDCompon := 0; Result.FirstCompon := nil; Result.FirstIDConnectedConnCompon := 0; Result.FirstConnectedConnCompon := nil; Result.LastIDCompon := 0; Result.LastCompon := nil; Result.LastIDConnectedConnCompon := 0; Result.LastConnectedConnCompon := nil; try //if Not isLineCompon(TForm(F_ProjMan), AIDLineComponent) then // Exit; ///// EXIT ///// with F_ProjMan do begin //LineCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDLineComponent); LineCompon := nil; if ALineComponent is TSCSComponent then LineCompon := TSCSComponent(ALineComponent); if (LineCompon <> nil) and (LineCompon.IsLine = biTrue) then begin if ALoadComponIDs then begin ResList := TIntList.Create; SCSComponents := F_ProjMan.GSCSBase.CurrProject.GetComponentsByWholeID(LineCompon.Whole_ID); try for i := 0 to SCSComponents.Count - 1 do begin //17.01.2013 PartCompon := SCSComponents[i]; //17.01.2013 if Assigned(PartCompon) then //17.01.2013 begin //17.01.2013 //GetMem(ptrID, SizeOf(Integer)); //17.01.2013 //ptrID^ := PartCompon.ID; //17.01.2013 ResList.Add(PartCompon.ID); //17.01.2013 end; ResList.Add(SCSComponents[i].ID); end; finally //12.03.2009 SCSComponents.Free; end; //SCSComponents.free; // Tolik 11/05/2019 -- if ResList.Count = 0 then begin ResList.Free; SCSComponents.Free; end else begin Result.WholeCompon := ResList; Result.WholeComponObj := SCSComponents; end; end; //*** Определить подключенные точечные компоненты ConnectedComponsInfo := GSCSBase.CurrProject.ConnectedComponsList.GetConnectedComponsInfoByWholeID(LineCompon.Whole_ID); try WasFrom := false; WasTo := false; for i := 0 to ConnectedComponsInfo.Count - 1 do begin ptrConnectedComponsInfo := ConnectedComponsInfo[i]; case ptrConnectedComponsInfo.TypeConnect of tcoFrom: begin Result.FirstIDCompon := ptrConnectedComponsInfo.IDSideCompon; Result.FirstIDConnectedConnCompon := ptrConnectedComponsInfo.IDConnectCompon; WasFrom := true; end; tcoTo: begin if WasTo and Not WasFrom then if Result.LastIDConnectedConnCompon = 0 then begin Result.FirstIDCompon := Result.LastIDCompon; Result.FirstIDConnectedConnCompon := Result.LastIDConnectedConnCompon; end; Result.LastIDCompon := ptrConnectedComponsInfo.IDSideCompon; Result.LastIDConnectedConnCompon := ptrConnectedComponsInfo.IDConnectCompon; WasTo := true; end; end; end; finally FreeList(ConnectedComponsInfo); end; {//*** Определить подключенные точечные компоненты ptrConnectedComponsInfo := GSCSBase.CurrProject.ConnectedComponsList.GetConnectedComponsInfoByWholeIDAndType(LineCompon.Whole_ID, tcoFrom); if ptrConnectedComponsInfo <> nil then begin Result.FirstIDCompon := ptrConnectedComponsInfo.IDSideCompon; Result.FirstIDConnectedConnCompon := ptrConnectedComponsInfo.IDConnectCompon; end; ptrConnectedComponsInfo := GSCSBase.CurrProject.ConnectedComponsList.GetConnectedComponsInfoByWholeIDAndType(LineCompon.Whole_ID, tcoTo); if ptrConnectedComponsInfo <> nil then begin Result.LastIDCompon := ptrConnectedComponsInfo.IDSideCompon; Result.LastIDConnectedConnCompon := ptrConnectedComponsInfo.IDConnectCompon; end; } { if SetFilterToSQLMemTable(tSQL_ConnectedComponents, 'compon_whole_id = '''+IntToStr(LineCompon.Whole_ID)+'''') then tSQL_ConnectedComponents.First; while Not tSQL_ConnectedComponents.Eof do begin case tSQL_ConnectedComponents.FieldByName(fnTypeConnect).AsInteger of tcoTo: begin Result.LastIDCompon := tSQL_ConnectedComponents.FieldByName(fnIDSideCompon).AsInteger; Result.LastIDConnectedConnCompon := tSQL_ConnectedComponents.FieldByName(fnIDConnectCompon).AsInteger; end; tcoFrom: begin Result.FirstIDCompon := tSQL_ConnectedComponents.FieldByName(fnIDSideCompon).AsInteger; Result.FirstIDConnectedConnCompon := tSQL_ConnectedComponents.FieldByName(fnIDConnectCompon).AsInteger; end; end; tSQL_ConnectedComponents.Next; end;} end; { if IDWholeCompon <> 0 then begin ResList := TList.Create; SetFilterToSQLMemTable(tSQL_Component, 'whole_id = '''+IntToStr(IDWholeCompon)+''''); IntFieldToListFromSQLMemTable(ResList, tSQL_Component, fnID); if ResList.Count = 0 then ResList.Free else Result.WholeCompon := ResList; //*** Определить подключенные точечные компоненты if SetFilterToSQLMemTable(tSQL_ConnectedComponents, 'compon_whole_id = '''+IntToStr(IDWholeCompon)+'''') then tSQL_ConnectedComponents.First; while Not tSQL_ConnectedComponents.Eof do begin case tSQL_ConnectedComponents.FieldByName(fnTypeConnect).AsInteger of tcoTo: begin Result.LastIDCompon := tSQL_ConnectedComponents.FieldByName(fnIDSideCompon).AsInteger; Result.LastIDConnectedConnCompon := tSQL_ConnectedComponents.FieldByName(fnIDConnectCompon).AsInteger; end; tcoFrom: begin Result.FirstIDCompon := tSQL_ConnectedComponents.FieldByName(fnIDSideCompon).AsInteger; Result.FirstIDConnectedConnCompon := tSQL_ConnectedComponents.FieldByName(fnIDConnectCompon).AsInteger; end; end; tSQL_ConnectedComponents.Next; end; end; } { if IDWholeCompon <> 0 then begin ResList := TList.Create; SetSQLToQuery(scsQSelect, ' select id from component where whole_id = '''+IntToStr(IDWholeCompon)+''' '); IntFieldToList(ResList, scsQSelect, 'id'); if ResList.Count = 0 then ResList.Free else Result.WholeCompon := ResList; //*** Определить подключенные точечные компоненты SetSQLToQuery(scsQSelect, ' select * from connected_components where compon_whole_id = '''+IntToStr(IDWholeCompon)+''' '); while Not scsQSelect.Eof do begin case scsQSelect.GetFNAsInteger('type_connect') of tcoTo: begin Result.LastIDCompon := scsQSelect.GetFNAsInteger('id_side_compon'); Result.LastIDConnectedConnCompon := scsQSelect.GetFNAsInteger('id_connect_compon'); end; tcoFrom: begin Result.FirstIDCompon := scsQSelect.GetFNAsInteger('id_side_compon'); Result.FirstIDConnectedConnCompon := scsQSelect.GetFNAsInteger('id_connect_compon'); end; end; scsQSelect.Next; end; end; } //if Result.LastIDCompon = 0 then // Result.LastIDCompon := -1; //if Result.LastIDConnectedConnCompon = 0 then // Result.LastIDConnectedConnCompon := -1; //if Result.FirstIDCompon = 0 then // Result.FirstIDCompon := -1; //if Result.FirstIDConnectedConnCompon = 0 then // Result.FirstIDConnectedConnCompon := -1; end; except on E: Exception do AddExceptionToLog('GetLineComponsInTraceFromBase: '+E.Message); end; end; procedure GetFirstLastLineComponsFromComponsInTrace(ATraceCompons: TList; var AFirstCompon: Integer; var ALastCompon: Integer); var i: Integer; IDCompon: Integer; FirstCompon: Integer; LastCompon: Integer; begin FirstCompon := -1; LastCompon := -1; with F_ProjMan.DM do for i := 0 to ATraceCompons.Count - 1 do begin IDCompon := Integer(ATraceCompons.Items[i]^); SetSQLToQuery(scsQSelect, ' select count(id) As Cnt from intrface '); end; end; // ##### Вернет список ID-в трасс на которых находяться компоненты, что в AListCompon ##### function GetTraceByListCompon(AListCompon: TIntList): TIntList; var ResList: TIntList; //ptrIDSCSFigure: ^Integer; IDCompon: Integer; i: Integer; SCSObject: TSCSCatalog; SCSCompon: TSCSComponent; begin Result := nil; if AListCompon = nil then Exit; ///// EXIT ///// with F_ProjMan do begin ResList := TIntList.Create; for i := 0 to AListCompon.Count - 1 do begin SCSCompon := GSCSBase.CurrProject.GetComponentFromReferences(AListCompon.Items[i]); if (SCSCompon <> nil) and (SCSCompon.IsLine = biTrue) then begin SCSObject := SCSCompon.GetFirstParentCatalog; if (SCSObject <> nil) and (SCSObject.ItemType = itSCSLine ) and (ResList.IndexOf(SCSObject.SCSID) = -1) {CheckNoIDinList(SCSObject.SCSID, ResList)} then begin //New(ptrIDSCSFigure); //GetMem(ptrIDSCSFigure, SizeOf(Integer)); //ptrIDSCSFigure^ := SCSObject.ScsID; ResList.Add(SCSObject.ScsID); end; end; end; If ResList.Count > 0 then Result := ResList else FreeAndNil(ResList); end; end; // ##### Вернет список ID-в трасс на которых находяться объекты, что в AListObjects ##### function GetTraceByListOjects(AListObjects: TList): TList; var ResList: TList; i: Integer; IDFigureTrace: Integer; ptrID: ^Integer; SCSCatalog: TSCSCatalog; begin Result := nil; try ResList := nil; if AListObjects = nil then Exit; ///// EXIT ///// ResList := TList.Create; with F_ProjMan.DM do for i := 0 to AListObjects.Count - 1 do begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferences(Integer(AListObjects[i]^)); if SCSCatalog <> nil then begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := SCSCatalog.ID; ResList.Add(ptrID); end; end; if ResList.Count = 0 then ResList.Free else Result := ResList; except on E: Exception do AddExceptionToLog(': '+E.Message); end; end; function GetTraceInfoFromListByPosition(ATraceInfo: TList; APosition: TTraceTypePorition): TList; var i: Integer; ptrCurTraceInfo: PTraceInfo; ptrResTraceInfo: PTraceInfo; begin Result := Tlist.Create; for i := 0 to ATraceInfo.Count - 1 do begin ptrCurTraceInfo := ATraceInfo[i]; if ptrCurTraceInfo.Position = APosition then begin GetMem(ptrResTraceInfo, SizeOf(TTraceInfo)); ptrResTraceInfo^ := ptrCurTraceInfo^; Result.Add(ptrResTraceInfo); end; end; end; function GetTraceInfoFromListByHorzHeight(ATraceInfo: TList; ALoHeight, AUpHeight: Double; ALoHitToBoundIfBetween, AUpHitToBoundIfBetween: Boolean; ALoadedTracesInfo: TList = nil): TList; //const // Delta = 0.01; var i, j: Integer; ptrCurTraceInfo: PTraceInfo; ptrResTraceInfo: PTraceInfo; TraceInHeight: Boolean; IsLoadedTraceInfo: Boolean; ptrLoadedTraceInfo: PTraceInfo; begin Result := Tlist.Create; for i := 0 to ATraceInfo.Count - 1 do begin ptrCurTraceInfo := ATraceInfo[i]; if ptrCurTraceInfo.Position = tpHorizontal then begin //*** Проверить Небыла ли трасса загружена в список раньше IsLoadedTraceInfo := false; if ALoadedTracesInfo <> nil then for j := 0 to ALoadedTracesInfo.Count - 1 do begin ptrLoadedTraceInfo := ALoadedTracesInfo[j]; if ptrCurTraceInfo.FigureID = ptrLoadedTraceInfo.FigureID then begin IsLoadedTraceInfo := true; Break; //// BREAK //// end; end; if Not IsLoadedTraceInfo then begin TraceInHeight := false; if (ALoHeight >= 0) and (AUpHeight >= 0) and (AUpHeight - ALoHeight > cnstCmpLenDelta) then //Высоты не одинаковы begin if Abs(ptrCurTraceInfo.HeightSide1 - ptrCurTraceInfo.HeightSide2) < cnstCmpLenDelta then //трасса горизонтальная if ((ALoHitToBoundIfBetween and (ALoHeight <= ptrCurTraceInfo.HeightSide1)) or //трасса может попасть в нижнюю границу (Not ALoHitToBoundIfBetween and (ptrCurTraceInfo.HeightSide1 - ALoHeight >= cnstCmpLenDelta))) and //трасса НЕ может попасть в нижнюю границу ((AUpHitToBoundIfBetween and (AUpHeight >= ptrCurTraceInfo.HeightSide1)) or //трасса может попасть в верхнюю границу (Not AUpHitToBoundIfBetween and (AUpHeight - ptrCurTraceInfo.HeightSide1 >= cnstCmpLenDelta))) then //трасса НЕ может попасть в верхнюю границу TraceInHeight := true; end else begin if (ALoHeight >= 0) and (abs(ptrCurTraceInfo.HeightSide1 - ALoHeight) < cnstCmpLenDelta) then TraceInHeight := true else if (AUpHeight >= 0) and (abs(ptrCurTraceInfo.HeightSide1 - AUpHeight) < cnstCmpLenDelta) then TraceInHeight := true; end; if TraceInHeight then begin GetMem(ptrResTraceInfo, SizeOf(TTraceInfo)); ptrResTraceInfo^ := ptrCurTraceInfo^; Result.Add(ptrResTraceInfo); if ALoadedTracesInfo <> nil then ALoadedTracesInfo.Add(ptrResTraceInfo); end; end; end; end; end; function GetTraceInfoFromListBySelected(ATraceInfo: TList; ASelected: Boolean): TList; var i: Integer; ptrCurTraceInfo: PTraceInfo; ptrResTraceInfo: PTraceInfo; begin Result := Tlist.Create; for i := 0 to ATraceInfo.Count - 1 do begin ptrCurTraceInfo := ATraceInfo[i]; if ptrCurTraceInfo.IsSelected = ASelected then begin GetMem(ptrResTraceInfo, SizeOf(TTraceInfo)); ptrResTraceInfo^ := ptrCurTraceInfo^; Result.Add(ptrResTraceInfo); end; end; end; function GetTraceInfoNoHitToListByFigureID(ATraceInfo: TList; AList: TList): TList; var i, j: Integer; ptrTraceInfoFromSrc: PTraceInfo; ptrTraceInfoFromList: PTraceInfo; ptrTraceInfoNoHit: PTraceInfo; IsHitToList: Boolean; begin Result := TList.Create; for i := 0 to ATraceInfo.Count - 1 do begin ptrTraceInfoFromSrc := ATraceInfo[i]; IsHitToList := false; for j := 0 to AList.Count - 1 do begin ptrTraceInfoFromList := AList[j]; if ptrTraceInfoFromSrc.FigureID = ptrTraceInfoFromList.FigureID then begin IsHitToList := true; Break; ///// BREAK ///// end; end; if Not IsHitToList then begin GetMem(ptrTraceInfoNoHit, SizeOf(TTraceInfo)); ptrTraceInfoNoHit^ := ptrTraceInfoFromSrc^; Result.Add(ptrTraceInfoNoHit); end; end; end; function GetFigureIDsBetweenOnWholeComponent(ALineComponent: TObject): TIntList; var LineComponent: TSCSComponent; FirstLineComponent: TSCSComponent; LastLineComponent: TSCSComponent; PartComponent: TSCSComponent; PartComponentOwner: TSCSCatalog; IDConnector1: Integer; IDConnector2: Integer; i: Integer; begin Result := TIntList.Create; LineComponent := TSCSComponent(ALineComponent); FirstLineComponent := LineComponent.ProjectOwner.GetComponentFromReferences(LineComponent.FirstIDCompon); LastLineComponent := LineComponent.ProjectOwner.GetComponentFromReferences(LineComponent.LastIDCompon); if (FirstLineComponent <> nil) and (LastLineComponent <> nil) then begin for i := 0 to LineComponent.WholeComponent.Count - 1 do begin PartComponent := LineComponent.ProjectOwner.GetComponentFromReferences(LineComponent.WholeComponent[i]); PartComponentOwner := PartComponent.GetFirstParentCatalog; if PartComponentOwner <> nil then begin Result.Add(PartComponentOwner.SCSID); if (PartComponent <> FirstLineComponent) and (PartComponent <> LastLineComponent) then begin IDConnector1 := -1; IDConnector2 := -1; GetConnObjectsByLine(PartComponentOwner.ListID, PartComponentOwner.SCSID, IDConnector1, IDConnector2); if IDConnector1 <> -1 then Result.Add(IDConnector1); if IDConnector2 <> -1 then Result.Add(IDConnector2); end; end; end; end; end; function GetProjectLists(AIDCatalogProject: Integer): TList; var ResList: TList; i: Integer; ptrID: ^Integer; begin Result := nil; try ResList := TList.Create; with F_ProjMan do for i := 0 to GSCSBase.CurrProject.ProjectLists.Count - 1 do if Assigned(GSCSBase.CurrProject.ProjectLists) then begin GetMem(ptrID, SizeOf(Integer)); ptrID^ := GSCSBase.CurrProject.ProjectLists[i].CurrID; ResList.Add(ptrID); end; if ResList.Count = 0 then ResList.Free else Result := ResList; except on E: Exception do AddExceptionToLog('GetProjectLists: '+E.Message); end; end; function CheckIsMetricUOM(AUOM: Integer): Boolean; begin Result := (AUOM = umMillimetr) or (AUOM = umSantimetr) or (AUOM = umMetr) or (AUOM = umKiloMetr); end; function CheckIsTradUOM(AUOM: Integer): Boolean; begin Result := (AUOM = umInch) or (AUOM = umFoot) or (AUOM = umMile); end; function CheckPriceTransformToUOMByCompType(ACompType: PComponentType): Boolean; begin Result := false; if ACompType <> nil then begin //if (GCompTypeSysNameCables.IndexOf(ACompType^.SysName) <> -1) or // (GCompTypeSysNameCableChannels.IndexOf(ACompType^.SysName) <> -1) then // Result := true; if ACompType^.IsLine = biTrue then if ACompType^.CanUseAsPoint = biFalse then Result := True; end; end; function GetComponNameForVisible(AName, ANameMark: String): String; begin Result := ''; Result := AName; if ANameMark <> '' then Result := AName + ' ' + ANameMark; {case GDBMode of bkNormBase: Result := AName; bkProjectManager: Result := AName + ' ' + ANameMark; end;} end; // ##### Вернет название с количеством, или без нево - в зависимости того, равно оно 0 ##### function GetNameAndKol(AName: String; AKol: Integer): String; begin if AKol > 0 then Result := AName + ' [ '+ IntToStr(AKol) +' ]' else Result := AName; end; function GetNameWithIndex(const AName: String; AIndex: Integer): String; begin Result := AName; if AIndex > 0 then Result := AName + IntToStr(AIndex); end; function GetNameAndIndex(AName: String; AItemType, AIndexPointObj, AIndexConn, AIndexLine: Integer): String; begin try Result := AName; case AItemType of itSCSLine: Result := GetNameWithIndex(AName, AIndexLine); itSCSConnector: begin if AIndexPointObj <> 0 then Result := GetNameWithIndex(AName, AIndexPointObj); if AIndexConn <> 0 then Result := GetNameWithIndex(AName, AIndexConn); end; end; except on E: Exception do AddExceptionToLog('GetNameAndIndex: '+E.Message); end; end; function GetNameAndIndexByTCatalog(ACatalog: TCatalog): String; begin Result := ''; Result := GetNameAndIndex(ACatalog.Name, ACatalog.ItemType, ACatalog.IndexPointObj, ACatalog.IndexConnector, ACatalog.IndexLine); end; function GetNameAndIndexByTSCSCatalog(ASCSCatalog: TObject): String; begin Result := ''; Result := GetNameAndIndex(TSCSCatalog(ASCSCatalog).Name, TSCSCatalog(ASCSCatalog).ItemType, TSCSCatalog(ASCSCatalog).IndexPointObj, TSCSCatalog(ASCSCatalog).IndexConnector, TSCSCatalog(ASCSCatalog).IndexLine); end; function GetNameInterfaceMultipleForLine: String; begin Result := cMultiplePoinInterface+' ('+cMultipleLineInterfaceM+')'; end; function GetNameUOM2(AUOM: Integer): String; begin Result := GetNameUOM(AUOM, true, false)+'2'; end; function GetNameUOM3(AUOM: Integer): String; begin Result := GetNameUOM(AUOM, true, false)+'3'; end; function GetNameUOM(AUOM: Integer; AAsShort: Boolean; ACanUseShortSign: Boolean): String; begin Result := ''; if AAsShort then begin case AUOM of umMillimetr: Result := cumMM; umSantimetr: Result := cumSm; umMetr: Result := cumM; umKiloMetr: Result := cumKM; umInch: if ACanUseShortSign then Result := cumIn_Sign else Result := cumIn; umFoot: if ACanUseShortSign then Result := cumFt_Sign else Result := cumFt; umMile: Result := cumMi; umGramm: Result := cumGr; umKilogramm: Result := cumKg; umCentner: Result := cumCt; umTonna: Result := cumTn; umOunce: Result := cumOz; umPound: Result := cumLb; end; end else begin case AUOM of umMillimetr: Result := cumMillimetr; umSantimetr: Result := cumSantimetr; umMetr: Result := cumMetr; umKiloMetr: Result := cumKiloMetr; umInch: Result := cumInch; umFoot: Result := cumFoot; umMile: Result := cumMile; umGramm: Result := cumGramm; umKilogramm: Result := cumKilogramm; umCentner: Result := cumCentner; umTonna: Result := cumTonna; umOunce: Result := cumOunce; umPound: Result := cumPound; end; end; end; function GetNameUOMForCompon(AIzm: String; ACompType: PComponentType; AUOM: Integer): String; begin Result := AIzm; if ACompType <> nil then begin //if (GCompTypeSysNameCables.IndexOf(ACompType^.SysName) <> -1) or // (GCompTypeSysNameCableChannels.IndexOf(ACompType^.SysName) <> -1) then //begin // Result := GetNameUOM(AUOM, true); // if Result = '' then // Result := AIzm; //end; if ACompType^.IsLine = biTrue then if ACompType^.CanUseAsPoint = biFalse then begin Result := GetNameUOM(AUOM, true); if Result = '' then Result := AIzm; end; end; end; function GetNameUOMForProperty(const APropIzm, ASysName: String; AUOM: Integer): String; begin Result := APropIzm; //if APropIzm = '' then // Tolik -- 03/11/2017 -- //if GPropSysNameInUOM.IndexOf(ASysName) <> -1 then if CheckSysNameInUOM(ASysName) then // begin Result := GetNameUOM(AUOM, true); end else if (ASysName = pnOutDiametr) or (ASysName = pnInDiametr) then Result := GetNameUOM(ConvertUOMToMin(AUOM), true) else if (ASysName = pnOutSection) or (ASysName = pnInSection) then Result := GetNameUOM2(ConvertUOMToMin(AUOM)) else if (GPropSysNameInUOM2.IndexOf(ASysName) <> -1) then Result := GetNameUOM2(AUOM) else if (GPropSysNameInUOM3.IndexOf(ASysName) <> -1) then Result := GetNameUOM3(AUOM); end; function GetUOMFromPM: Integer; begin Result := F_ProjMan.FUOM; end; procedure SetUOMToPM(AUOM: Integer); begin F_ProjMan.FUOM := AUOM; end; { function MakeMarkMaskForComponent(AProj, AList, ARoom, AObj, ATopCompon, ACompon, APort: Integer; const AComponNameShort, AMask: String): String; var i: Integer; Len: Integer; CurrChar: Char; PrevChar: Char; NewMark: String; CursorInObject: Boolean; ObjBeginBracket: Char; begin try Result := ''; Len := Length(AMask); CurrChar := #0; PrevChar := #0; NewMark := ''; for i := 1 to Len do begin PrevChar := CurrChar; CurrChar := AMask[i]; if PrevChar = '#' then case CurrChar of 'p': //, 'P': //*** Проект NewMark := NewMark + IntToStr(AProj); 'l': //, 'L': //*** Лист NewMark := NewMark + IntToStr(AList); 'r': //, 'R': //*** Комната NewMark := NewMark + IntToStr(ARoom); 'o': //, 'O': //*** Объект NewMark := NewMark + IntToStr(AObj); 'C': //*** Верхний компонент NewMark := NewMark + IntToStr(ATopCompon); 'c': //, 'C': //*** Компонент NewMark := NewMark + IntToStr(ACompon); 't': //, 'T': //*** Порт NewMark := NewMark + IntToStr(APort); 's': //, 'S': NewMark := NewMark + AComponNameShort; end else if CurrChar <> '#' then NewMark := NewMark + CurrChar; end; Result := NewMark; except on E: Exception do AddExceptionToLog('MakeMarkMaskForComponent: '+E.Message); end; end; } // ##### Редактирование Масок типов ##### //04.01.2011 //procedure EditCatalogMarkMasksExecute(AID: Integer; AItemType: Integer = itList); //var IDCat: Integer; // List: TSCSList; // ListNode: TTreeNode; // //Project: TSCSProject; // MaskList: TList; //begin // try // with F_ProjMan do // begin // List := nil; // MaskList := nil; // case AItemType of // itList: // begin // List := GSCSBase.CurrProject.GetListBySCSID(AID); // if List <> nil then // MaskList := List.MarkMasks; // end; // itProject: // MaskList := GSCSBase.CurrProject.MarkMasks; // end; // //IDCat := DM.GetIDCatalogBySCSID(AID); // // if MaskList <> nil then // if F_ProjMan.F_ComponTypesMarkMask.ChangeMarkMasks(MaskList) then // begin // case AItemType of // itList: // begin // if List.SaveMarkMasks then // begin // RefreshComponMarks(List.ID); // ListNode := nil; // ListNode := F_ProjMan.FindComponOrDirInTree(List.ID, false); // if ListNode <> nil then // F_ProjMan.RefreshNodesText(ListNode, [itComponCon, itComponLine]); // end; // end; // itProject: // GSCSBase.CurrProject.SaveMarkMasks; // end; // end; // end; // except // on E: Exception do AddExceptionToLog('EditCatalogMarkMasksExecute: '+E.Message); // end; //end; function GetNBMarkTemplates: TList; var ptrCatalogMarkMask: PCatalogMarkMask; begin Result := TList.Create; with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select id, mark_mask from component_types '); while Not scsQSelect.Eof do begin ptrCatalogMarkMask := nil; //CanSaveMarkMask := true; //New(ptrCatalogMarkMask); GetMem(ptrCatalogMarkMask, SizeOf(TCatalogMarkMask)); ptrCatalogMarkMask.ID := -1; ptrCatalogMarkMask.IDCatalog := -1; ptrCatalogMarkMask.IDComponentType := scsQSelect.GetFNAsInteger('id'); ptrCatalogMarkMask.MarkMask := scsQSelect.GetFNAsString('Mark_Mask'); ptrCatalogMarkMask.MakeEdit := meMake; Result.Add(ptrCatalogMarkMask); scsQSelect.Next; end; scsQSelect.Close; end; end; function GetMarkMaskTemplateByCompTypeFromList(ATemplatesList: TList; AComponentType: Integer): PCatalogMarkMask; var i: Integer; ptrCatalogMarkMask: PCatalogMarkMask; begin Result := nil; try for i := 0 to ATemplatesList.Count - 1 do begin ptrCatalogMarkMask := ATemplatesList[i]; if ptrCatalogMarkMask.IDComponentType = AComponentType then begin Result := ptrCatalogMarkMask; Break; ///// BREAK ///// end; end; except on E: Exception do AddExceptionToLog('GetMarkMaskTemplateByCompTypeFromList: '+E.Message); end; end; function GetNBSettingsAsDefault: TNBSettingRecord; begin ZeroMemory(@Result, SizeOf(TNBSettingRecord)); Result.DBName := bnNB; Result.DBType := dbtUsual; if CurrentNBBuildID > Result.BuildID then Result.BuildID := CurrentNBBuildID; Result.NDS := 20; Result.UOM := umM; end; function GetNBSettings(AQuery: TpFIBQuery): TNBSettingRecord; begin Result := GetNBSettingsAsDefault; try AQuery.Close; AQuery.SQL.Text := 'select count(*) from '+ tnSettings; AQuery.ExecQuery; if AQuery.FN(fnCount).AsInteger > 0 then begin AQuery.Close; AQuery.SQL.Text := 'select * from '+ tnSettings; AQuery.ExecQuery; if AQuery.FieldIndex[fnDBType] <> -1 then begin Result.DBType := AQuery.FN(fnDBType).AsInteger; if Result.DBType = dbtNone then Result.DBType := dbtUsual; end; try Result.DBName := AQuery.FN(fnDBName).AsString; Result.BuildID := AQuery.FN(fnBuildID).AsInteger; Result.NDS := AQuery.FN(fnNDS).AsFloat; if AQuery.FieldIndex[fnBusyDate] <> -1 then begin Result.BusyDate := AQuery.FN(fnBusyDate).AsDate; Result.BusyTime := AQuery.FN(fnBusyTime).AsTime; Result.BusyType := AQuery.FN(fnBusyType).AsInteger; end; if AQuery.FieldIndex[fnBackUpDate] <> -1 then Result.BackUpDate := AQuery.FN(fnBackUpDate).AsDate; if AQuery.FieldIndex[fnUOM] <> -1 then Result.UOM := AQuery.FN(fnUOM).AsInteger; except end; end; AQuery.Close; except on E: Exception do AddExceptionToLog('GetNBSettings: '+E.Message); end; end; procedure SetNBSettings(ANBSettings: TNBSettingRecord; AQuery: TpFIBQuery); var RecCount: Integer; FieldList: TStringList; begin FieldList := TStringList.Create; FieldList.Add(fnBuildID); //FieldList.Add(fnDisableEditing); FieldList.Add(fnNDS); FieldList.Add(fnDBName); FieldList.Add(fnDBType); try //SetSQLToFIBQuery(AQuery, GetSQLByParams(qtDelete, tnSettings, '', nil, '')); //SetSQLToFIBQuery(AQuery, GetSQLByParams(qtInsert, tnSettings, '', FieldList, ''), false); RecCount := 0; SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, tnSettings, '', nil, fnCount+'('+fnAll+')')); if AQuery.RecordCount > 0 then RecCount := AQuery.Fields[0].AsInteger; if RecCount = 0 then SetSQLToFIBQuery(AQuery, GetSQLByParams(qtInsert, tnSettings, '', FieldList, ''), false) else SetSQLToFIBQuery(AQuery, GetSQLByParams(qtUpdate, tnSettings, '', FieldList, ''), false); AQuery.ParamByName(fnBuildID).AsInteger := ANBSettings.BuildID; AQuery.ParamByName(fnNDS).AsFloat := ANBSettings.NDS; AQuery.ParamByName(fnDBName).AsString := ANBSettings.DBName; AQuery.ParamByName(fnDBType).AsInteger := ANBSettings.DBType; AQuery.ExecQuery; AQuery.Close; finally FieldList.Free; end; end; function GetDBTypeByFileExtension(AFileName: String): Integer; var Extension: String; begin Result := dbtNone; Extension := AnsiUpperCase(ExtractFileExt(AFileName)); if Extension[1] = '.' then Delete(Extension, 1, 1); if Extension = AnsiUpperCase(enFolder) then Result := dbtCatalog; if Extension = AnsiUpperCase(enCompon) then Result := dbtComponent; end; function GetTableNameByDBType(ADBType: Integer): String; begin Result := ''; case ADBType of dbtCatalog: Result := tnCatalog; dbtComponent: Result := tnComponent; end; end; function GetTableNameFromTableFieldStr(ATableFieldStr: string): string; var PointPos: Integer; begin Result := ''; PointPos := Pos('.', ATableFieldStr); if PointPos <> 0 then Result := Copy(ATableFieldStr, 1, PointPos-1); end; function GetFieldNameFromTableFieldStr(ATableFieldStr: string): string; var PointPos: Integer; begin Result := ''; PointPos := Pos('.', ATableFieldStr); if PointPos <> 0 then Result := Copy(ATableFieldStr, PointPos+1, length(ATableFieldStr)); end; procedure AddNBComponGUIDToFreqUseObjByID(AComponID: Integer); var GUIDCompon: String; begin GUIDCompon := F_NormBase.DM.GetStringFromTableByID(tnComponent, fnGuid, AComponID, qmPhisical); if GUIDCompon <> '' then F_NormBase.DM.AddComponGUIDToFreqUseObj(GUIDCompon); end; procedure AddComponGUIDToNBFavorites(AGUID: String); var Ini: TIniFile; begin try if AGUID <> '' then begin Ini := TIniFile.Create(GetPathToNBComponFavorites); if Not Ini.ValueExists(fnGuid, AGUID) then Ini.WriteInteger(fnGuid, AGUID, 1); FreeAndNil(Ini); end; except on E: Exception do AddExceptionToLogEx('AddComponGUIDToNBFavorites', E.Message); end; end; procedure DelComponGUIDFromNBFavorites(AGUID: String); var Ini: TIniFile; begin try if AGUID <> '' then begin Ini := TIniFile.Create(GetPathToNBComponFavorites); if Ini.ValueExists(fnGuid, AGUID) then Ini.DeleteKey(fnGuid, AGUID); FreeAndNil(Ini); end; except on E: Exception do AddExceptionToLogEx('DelComponGUIDFromNBFavorites', E.Message); end; end; function CheckExistsComponGUIDInNBFavorites(AGUID: String): Boolean; var Ini: TIniFile; FName: String; begin Result := false; try FName := GetPathToNBComponFavorites; if FileExists(FName) then begin Ini := TIniFile.Create(FName); Result := Ini.ValueExists(fnGuid, AGUID); FreeAndNil(Ini); end; except on E: Exception do AddExceptionToLogEx('CheckExistsComponGUIDInNBFavorites', E.Message); end; end; function GetComponGUIDsFromNBFavorites: TStringList; var Ini: TIniFile; FName: String; begin Result := TStringList.Create; try FName := GetPathToNBComponFavorites; if FileExists(FName) then begin Ini := TIniFile.Create(FName); Ini.ReadSection(fnGuid, Result); FreeAndNil(Ini); end; except on E: Exception do AddExceptionToLogEx('GetComponGUIDsFromNBFavorites', E.Message); end; end; procedure AddFieldToTable(const ATableName, AFieldName: String; AFieldType: TFieldType; ASize: Integer; AQOperat: TpFIBQuery); var strSQL: string; //strFieldType: String; begin try strSQL := GetSQLForAddFieldToTable(ATableName, AFieldName, AFieldType, ASize, qmPhisical); if strSQL <> '' then begin AQOperat.Close; AQOperat.SQL.Text := strSQL; AQOperat.ExecQuery; AQOperat.Close; end; except on E: Exception do AddExceptionToLogEx('AddFieldToTable', E.Message); end; end; procedure AppendIDNameToMemTable(AID: Integer; const AName: String; AMemTable: TkbmMemTable); begin AMemTable.Append; AMemTable.FieldByName(fnID).AsInteger := AID; AMemTable.FieldByName(fnName).AsString := AName; AMemTable.Post; end; procedure BlobFieldToStrings(ABlobField: TBlobField; AStrings: TStrings); var Stream: TMemoryStream; begin Stream := TMemoryStream.Create; ABlobField.SaveToStream(Stream); Stream.Position := 0; AStrings.LoadFromStream(Stream); Stream.Free; end; procedure BlobFieldFromStrings(ABlobField: TBlobField; AStrings: TStrings); var Stream: TMemoryStream; begin Stream := TMemoryStream.Create; AStrings.SaveToStream(Stream); Stream.Position := 0; ABlobField.LoadFromStream(Stream); Stream.Free; end; function CheckConnectCountNoMoreOneToDataBase(ADataBase: TpFIBDataBase; AMessgFalse: string=''): Boolean; var CurrConnectionCount: Integer; begin Result := true; CurrConnectionCount := GetConnectedCountToDataBase(ADataBase); if CurrConnectionCount > 1 then begin Result := false; if AMessgFalse <> '' then MessageModal(AMessgFalse +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION); //if AMessgFalse = '' then // MessageModal(cBaseCommon42 +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION) //else // MessageModal(AMessgFalse +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION); end; end; function CheckConnectCountNoMoreOneToNB(AMessgFalse: string=''): Boolean; //var // CurrConnectionCount: Integer; begin Result := CheckConnectCountNoMoreOneToDataBase(F_NormBase.DM.Database_SCS, AMessgFalse); //Result := true; //CurrConnectionCount := GetCurrConnectionCount; //if CurrConnectionCount > 1 then //begin // Result := false; // if AMessgFalse = '' then // MessageModal(cBaseCommon42 +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION) // else // MessageModal(AMessgFalse +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION); //end; end; function CheckConnectCountNoMoreOneToPM(AMessgFalse: string=''): Boolean; //var // CurrConnectionCount: Integer; begin Result := CheckConnectCountNoMoreOneToDataBase(F_ProjMan.DM.Database_SCS, AMessgFalse); //Result := true; //CurrConnectionCount := 0; //if F_ProjMan <> nil then // if F_ProjMan.DM.Database_SCS.Connected then // CurrConnectionCount := F_ProjMan.DM.Database_SCS.UserNames.Count; //if CurrConnectionCount > 1 then //begin // Result := false; // if AMessgFalse = '' then // MessageModal(cBaseCommon42 +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION) // else // MessageModal(AMessgFalse +' '+ IntToStr(CurrConnectionCount), ApplicationName, MB_OK or MB_ICONINFORMATION); //end; end; function CheckFieldInTable(const ATableName, AFieldName: String; AQSelect: TpFIBQuery): Boolean; begin {Result := true; AQuery.Close; AQuery.SQL.Text := 'select '+AFieldName+' from '+ATableName+' where id = ''0'''; try AQuery.ExecQuery; except Result := false; end; AQuery.Close;} Result := false; SetSQLToFIBQuery(AQSelect, 'select RDB$FIELD_NAME from RDB$RELATION_FIELDS '+ 'where rdb$relation_name = '''+ATableName+''' '); while Not AQSelect.Eof do begin if AQSelect.Fields[0].AsString = AFieldName then begin Result := true; Break; //// BREAK //// end; AQSelect.Next; end; AQSelect.Close; end; function CheckFieldInTableByFirstRec(ATableName, AFieldName: String; AQuery: TpFIBQuery): Boolean; begin Result := true; try SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, ATableName, '', nil, fnFirst1+' '+AFieldName)); except Result := false; end; AQuery.Close; end; function CheckLocate(ADataSet: TDataSet; AFieldName: String; AValue: Variant): Boolean; var //CurrNo: Integer; //BookMarkStr: String; BookmarkStr: TBookMark; begin //CurrNo := ADataSet.RecNo; //Result := ADataSet.Locate(AFieldName, AValue, []); //ADataSet.RecNo := CurrNo; //BookMarkStr := ADataSet.Bookmark; BookMarkStr := ADataSet.getBookmark; try Result := ADataSet.Locate(AFieldName, AValue, []); finally //ADataSet.Bookmark := BookMarkStr; ADataSet.GotoBookmark(BookMarkStr); ADataSet.FreeBookmark(BookMarkStr); end; end; function CheckStrValueInTable(const ATableName, AFieldName, AValue: String; ANoIncludingID: Integer; AQuery: TpFIBQuery): Boolean; var strWhere: String; SQLText: String; begin Result := false; { strWhere := '('+AFieldName+' = '''+AValue+''')'; if ANoIncludingID > 0 then strWhere := strWhere + ' and Not('+fnID+' = '''+IntToStr(ANoIncludingID)+''')'; SQLText := 'select count(id) from '+ATableName+' where '+strWhere; SetSQLToFIBQuery(AQuery, SQLText); if AQuery.Fields[0].AsInteger > 0 then Result := true; } strWhere := '('+AFieldName+' = :'+AFieldName+')'; if ANoIncludingID > 0 then strWhere := strWhere + ' and Not('+fnID+' = :'+fnID+')'; SQLText := 'select count(id) from '+ATableName+' where '+strWhere; AQuery.Close; if Not((AQuery.SQL.Count = 1) and (AQuery.SQL[0] = SQLText)) then SetSQLToFIBQuery(AQuery, SQLText, false); AQuery.Params[0].AsString := AValue; if ANoIncludingID > 0 then AQuery.Params[1].AsInteger := ANoIncludingID; AQuery.ExecQuery; if AQuery.Fields[0].AsInteger > 0 then Result := true; end; function CheckValueInMT(AMemTable: TkbmMemTable; AFieldName: String; AValue: Variant): Boolean; var // BookMarkStr: string; BookmarkStr: TBookMark; begin Result := false; //BookMarkStr := AMemTable.Bookmark; BookMarkStr := AMemTable.GetBookmark; AMemTable.DisableControls; try if AMemTable.Locate(AFieldName, AValue, []) then Result := true; //AMemTable.Bookmark := BookMarkStr; AMemTable.GotoBookmark(BookMarkStr); AMemTable.FreeBookmark(BookMarkStr); finally AMemTable.EnableControls; end; end; function CheckExistsTableInBase(AQSelect: TpFIBQuery; ATableName: String): Boolean; begin Result := false; SetSQLToFIBQuery(AQSelect, 'select rdb$relation_name from rdb$relations '+ 'where (rdb$system_flag = 0) and (rdb$view_source is null) and '+ '(rdb$relation_name = '''+ATableName+''') '+ 'order by rdb$relation_name asc '); if AQSelect.RecordCount > 0 then if AQSelect.FN('rdb$relation_name').AsString = ATableName then Result := True; end; function CopyBase(ASrcDBName, ANewDBName: String; ADelSrcBase: Boolean = false): Boolean; begin Result := false; if FileExists(ANewDBName) then DeleteFile(ANewDBName); Result := CopyFileTo(ASrcDBName, ANewDBName); if ADelSrcBase then DeleteFile(ASrcDBName); end; procedure CopyBlobFromFNToParamInQuery(ADestQuery, ASrcQuery: TpFIBQuery; AParamName, AFieldName: String); var BufStram: TStream; begin if Assigned(ADestQuery) and Assigned(ASrcQuery) then begin SaveToStreamFromQr(ASrcQuery, BufStram, AFieldName, true); LoadFromStreamToQr(ADestQuery, BufStram, AParamName, true); end; end; procedure DeactiveDataSets(AComponentOwner: TComponent); var i: Integer; CurrCompon: TComponent; begin try for i := 0 to AComponentOwner.ComponentCount - 1 do begin CurrCompon := AComponentOwner.Components[i]; if CurrCompon <> nil then begin if CurrCompon is TpFIBDataSet then begin if TpFIBDataSet(CurrCompon).Active then TpFIBDataSet(CurrCompon).Close; TpFIBDataSet(CurrCompon).Transaction := nil; end else if CurrCompon is TDataSet then if TDataSet(CurrCompon).Active then TDataSet(CurrCompon).Close; //if CurrCompon is TpFIBTransaction then // TpFIBTransaction(CurrCompon).DefaultDatabase := nil; end; end; except end; end; procedure DefineBusyFieldsInBase(AQSelect, AQOperat: TpFIBQuery); begin try if Not CheckFieldInTable(tnSettings, fnBusyDate, AQSelect) then AddFieldToTable(tnSettings, fnBusyDate, ftDate, 0, AQOperat); if Not CheckFieldInTable(tnSettings, fnBusyTime, AQSelect) then AddFieldToTable(tnSettings, fnBusyTime, ftTime, 0, AQOperat); if Not CheckFieldInTable(tnSettings, fnBusyType, AQSelect) then AddFieldToTable(tnSettings, fnBusyType, ftInteger, 0, AQOperat); // поле BACKUP_DATE if Not CheckFieldInTable(tnSettings, fnBackUpDate, AQSelect) then begin AddFieldToTable(tnSettings, fnBackUpDate, ftDate, 0, AQOperat); //*** Добавить текущую дату сервера в новое поле UpdateTableFieldAllRec(AQOperat, tnSettings, fnBackUpDate, GetBaseNow(AQSelect)); end; //IGOR -- 01/10/2020 -- if Not CheckFieldInTable(tnSettings, 'USERINFO', AQSelect) then begin AddFieldToTable(tnSettings, 'USERINFO', ftString, 200, AQOperat); AQSelect.Database.Close; AQSelect.Database.Open; end; // except on E: Exception do AddExceptionToLogEx('DefineBusyFieldsInBase', E.Message); end; end; procedure DefineSpavIDsBySpravGUIDs(ADestTableName, ASpravTableName, ADstFieldNameID, ADstFieldNameGUID: String; AQSelect, AQOperat: TpFIBQuery); var GUIDList: TStringList; IDList: TIntList; CurrGUID: String; CurrID: Integer; i: Integer; begin GUIDList := TStringList.Create; IDList := TIntList.Create; //*** Отобрать все Гуиды для справочной таблици из целевой SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ADestTableName, ADstFieldNameID+' is null', nil, ADstFieldNameGUID)); while Not AQSelect.Eof do begin CurrGUID := AQSelect.Fields[0].AsString; if (CurrGUID <> '') and (GUIDList.IndexOf(CurrGUID) = -1) then GUIDList.Add(CurrGUID); AQSelect.Next; end; //*** Найти ID-ки из справ-й таблици SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ASpravTableName, fnGUID+' = :'+fnGUID, nil, fnID), false); for i := 0 to GUIDList.Count - 1 do begin AQSelect.Close; AQSelect.Params[0].AsString := GUIDList[i]; AQSelect.ExecQuery; CurrID := 0; if AQSelect.RecordCount > 0 then CurrID := AQSelect.Fields[0].AsInteger; IDList.Add(CurrID); end; //*** В целевую таблицу занести найденные ID-ки SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ADestTableName, ADstFieldNameGUID+' = :'+ADstFieldNameGUID, nil, ADstFieldNameID), false); for i := 0 to GUIDList.Count - 1 do begin if IDList[i] > 0 then begin AQOperat.Close; AQOperat.ParamByName(ADstFieldNameGUID).AsString := GUIDList[i]; AQOperat.ParamByName(ADstFieldNameID).AsInteger := IDList[i]; AQOperat.ExecQuery; end; end; GUIDList.Free; IDList.Free; end; procedure DelFieldFromTable(const ATableName, AFieldName: String; AQOperat: TpFIBQuery); begin try SetSQLToFIBQuery(AQOperat, 'alter table '+ATableName+' drop '+AFieldName); except on E: Exception do AddExceptionToLogEx('DelFieldFromTable', E.Message); end; end; function GetAllIDsFromTable(ATableName: String; AQSelect: TpFIBQuery): TIntList; begin Result := TIntList.Create; SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, ATableName, '', nil, fnID)); IntFIBFieldToIntList(Result, AQSelect, fnID); end; function GetBaseNow(AQSelect: TpFIBQuery): TDateTime; begin Result := 0; SetSQLToFIBQuery(AQSelect, 'select cast(''now'' as timestamp) as DatTim from '+tnRDBDatabase); Result := AQSelect.Fields[0].AsDateTime; end; function GetBaseParam(AParamName, AValue: String): String; begin Result := AParamName+'='+AValue; end; function GetConnectedCountToDataBase(ADataBase: TpFIBDataBase): Integer; var i: Integer; ServiceUsers: TStringList; begin Result := 0; try if ADataBase.Connected then begin Result := ADataBase.UserNames.Count; {ServiceUsers := TStringList.Create; ServiceUsers.Add('(SQL SERVER)'); for i := 0 to ADataBase.UserNames.Count - 1 do begin if ServiceUsers.IndexOf(AnsiUpperCase(ADataBase.UserNames[i])) = -1 then Result := Result + 1; end;} end; except on E: Exception do AddExceptionToLogEx('GetConnectedCountToDataBase', E.Message); end; end; function GetDirItemTypeByGuideFileType(AGuideFileType: Integer): Integer; begin Result := ditNone; case AGuideFileType of gftCompSpecification: Result := ditCompSpecifications; end; end; function GetFieldNamesFromFIBQuery(AQuery: TpFIBQuery): TStringList; var i: Integer; begin Result := nil; if Assigned(AQuery) then begin Result := TStringList.Create; for i := 0 to AQuery.FieldCount - 1 do //if AnsiUpperCase(AQuery.Fields[i].Name) <> 'DEFAULT' then Result.Add(AQuery.Fields[i].Name); //else // Result.Add('"'+AQuery.Fields[i].Name+'"'); end; end; function GetFieldLengthInTable(ATableName, AFieldName: String; AQSelect: TpFIBQuery): Integer; begin Result := -1; GetFieldInfo(ATableName, AFieldName, AQSelect); while Not AQSelect.Eof do begin if AQSelect.FN('RDB$FIELD_NAME').AsString = AFieldName then begin Result := AQSelect.FN('RDB$FIELD_LENGTH').AsInteger; Break; //// BREAK //// end; AQSelect.Next; end; AQSelect.Close; end; function GetFieldPositionInTable(ATableName, AFieldName: String; AQSelect: TpFIBQuery): Integer; begin Result := -1; SetSQLToFIBQuery(AQSelect, 'select RDB$FIELD_NAME, RDB$FIELD_POSITION from RDB$RELATION_FIELDS '+ 'where rdb$relation_name = '''+ATableName+''' '); while Not AQSelect.Eof do begin if AQSelect.Fields[0].AsString = AFieldName then begin Result := AQSelect.Fields[1].AsInteger; Break; //// BREAK //// end; AQSelect.Next; end; AQSelect.Close; end; procedure GetFieldInfo(const ATableName, AFieldName: String; AQSelect: TpFIBQuery); var FldCondition: String; begin FldCondition := ''; if AFieldName <> '' then begin FldCondition := ' and (RDB$RELATION_FIELDS.RDB$FIELD_NAME = '''+AFieldName+''')'; end; SetSQLToFIBQuery(AQSelect, 'select '+ 'RDB$RELATION_FIELDS.RDB$FIELD_NAME, '+ 'RDB$RELATION_FIELDS.RDB$FIELD_POSITION, '+ 'RDB$FIELDS.RDB$FIELD_TYPE, '+ 'RDB$FIELDS.RDB$FIELD_LENGTH '+ 'from RDB$RELATION_FIELDS, RDB$FIELDS '+ 'where (rdb$relation_name = '''+ATableName+''') and '+ '(RDB$FIELDS.RDB$FIELD_NAME = RDB$RELATION_FIELDS.RDB$FIELD_SOURCE) '+ FldCondition); end; function GetFieldsFromTable(const ATableName: String; AFieldTypes: TIntList; AQSelect: TpFIBQuery): TStringList; begin Result := TStringList.Create; //SetSQLToFIBQuery(AQSelect, 'select RDB$RELATION_FIELDS.RDB$FIELD_NAME, RDB$FIELD_TYPE '+ // 'from RDB$RELATION_FIELDS, RDB$FIELDS '+ // 'where (rdb$relation_name = '''+ATableName+''') and '+ // '(RDB$FIELDS.RDB$FIELD_NAME = RDB$RELATION_FIELDS.RDB$FIELD_SOURCE) '); GetFieldInfo(ATableName, '', AQSelect); while Not AQSelect.Eof do begin if (AFieldTypes = nil) or (AFieldTypes.IndexOf(AQSelect.FN('RDB$FIELD_TYPE').AsInteger) <> -1) then begin Result.Add(AQSelect.FN('RDB$FIELD_NAME').AsString); end; AQSelect.Next; end; AQSelect.Close; end; function GetMasterFNameByDirItemType(ADirItemType: Integer): String; begin Result := ''; case ADirItemType of ditComponentType: Result := fnIDComponentType; ditCurrency: Result := fnIDCurrency; ditInterface: Result := fnIDInterface; ditNBNorm: Result := fnIDNBNorm; ditNBResource: Result := fnIDNBResource; ditNetType: Result := fnIDNetType; ditObjectIcon: Result := fnIDObjectIcon; ditProducer: Result := fnIDProducer; ditProperty: Result := fnIDProperty; ditSuppliesKinds: Result := fnIDSuppliesKind; ditUnitsOfMeasure: Result := fnIDInputString; //fnIDUnitOfMeasure; ditDimensions: Result := fnIDInputString; //fnIDDimension; ditCompSpecifications: Result := fnIDFile; end; end; function GetSQLByParams(AQueryType: TQueryType; const ATableName, AWherePart: String; AFieldList: TStringList; const AOneFieldName: String): String; var SQLtxt: String; FieldsStr: String; i: Integer; function GetFieldsStr(AQType: TQueryType): String; var i: Integer; ResFieldsStr: String; begin ResFieldsStr := ''; if Assigned(AFieldList) then begin for i := 0 to AFieldList.Count - 1 do begin case AQType of qtSelect: ResFieldsStr := ResFieldsStr + AFieldList.Strings[i]; qtInsert: ResFieldsStr := ResFieldsStr +':'+ AFieldList.Strings[i]; //qtUpdate: ResFieldsStr := ResFieldsStr + '"'+ AFieldList.Strings[i]+'" = :'+AFieldList.Strings[i]; qtUpdate: ResFieldsStr := ResFieldsStr + AFieldList.Strings[i]+' = :'+AFieldList.Strings[i]; end; if i < AFieldList.Count - 1 then ResFieldsStr := ResFieldsStr + ', '; end; end else if AoneFieldName <> '' then case AQType of qtSelect: ResFieldsStr := ResFieldsStr + AoneFieldName; qtInsert: ResFieldsStr := ResFieldsStr +':'+ AoneFieldName; qtUpdate: ResFieldsStr := ResFieldsStr + AoneFieldName+' = :'+AoneFieldName; end; Result := ResFieldsStr; end; begin Result := ''; SQLtxt := ''; FieldsStr := ''; case AQueryType of qtSelect: begin FieldsStr := GetFieldsStr(qtSelect); SQLtxt := ' select '+FieldsStr+' from '+ATableName+' '; end; qtInsert: begin FieldsStr := GetFieldsStr(qtSelect); SQLtxt := ' insert into '+ATableName+' ('+FieldsStr+') '+' values('; FieldsStr := GetFieldsStr(qtInsert); SQLtxt := SQLtxt + FieldsStr+' )'; end; qtUpdate: begin FieldsStr := GetFieldsStr(qtUpdate); SQLtxt := ' update '+ATableName+' set '+FieldsStr+ ' '; end; qtDelete: SQLtxt := ' delete from '+ATableName+' '; end; if AWherePart <> '' then SQLtxt := SQLtxt + ' where '+AWherePart; Result := SQLtxt; end; function GetSQLFieldsAsStr(AFields: TStrings; const APref: String=''): String; var i: Integer; begin Result := ''; for i := 0 to AFields.Count - 1 do begin if i > 0 then Result := Result + ','; Result := Result + APref+AFields[i]; end; end; function GetSQLForAddFieldToTable(ATableName, ANewFieldName: String; AFieldType: TFieldType; ASize: Integer; AQueryMode: TQueryMode): String; var strFieldType: String; begin Result := ''; strFieldType := GetStrFieldType(AFieldType, ASize); if strFieldType <> '' then case AQueryMode of qmPhisical: Result := 'ALTER TABLE '+ATableName+' ADD '+ANewFieldName+' '+strFieldType+' '; qmMemory: Result := 'ALTER TABLE '+ATableName+' ADD ('+ANewFieldName+' '+strFieldType+'); '; end; end; function GetSQLForDropField(ATableName, AFieldName: String): String; begin Result := 'ALTER TABLE '+ATableName+' drop '+AFieldName; end; function GetSQLForDropIndex(AIndexName: String): String; begin Result := 'DROP INDEX '+AIndexName; end; function GetSQLForInsertCompRel: String; var FieldNames: TStringList; begin Result := ''; FieldNames := TStringList.Create; FieldNames.Add(fnIDComponent); FieldNames.Add(fnIDChild); FieldNames.Add(fnKolvo); FieldNames.Add(fnIDTopCompon); FieldNames.Add(fnIDParentCompRel); FieldNames.Add(fnKolSubComplect); FieldNames.Add(fnConnectType); FieldNames.Add(fnSortID); Result := GetSQLByParams(qtInsert, tnComponentRelation, '', FieldNames, ''); FreeAndNil(FieldNames); end; function GetSQLForIsVisible(ATableName: string): string; var TableName: string; begin TableName := ''; if ATableName <> '' then TableName := ATableName + '.'; Result := '('+TableName + fnIsVisible+' = '''+IntToStr(biTrue)+''')'; end; function GetSQLForIsVisibleWithFieldIntValue(ATableName, AFiledName: string; AFieldValue: Integer): string; begin Result := GetSQLForIsVisible(ATableName); Result := Result + ' or ('+AFiledName+' = '''+IntToStr(AFieldValue)+''')'; end; function GetSQLOpeatorIN(AFieldName, APreviosConditions: String; AIDList: TintList): string; var i: integer; begin Result := ''; if AIDList.Count > 0 then begin if AIDList.Count = 1 then Result := '('+AFieldName+' = '''+IntToStr(AIDList[0])+''')' else begin Result := '('+AFieldName+' in ('; for i := 0 to AIDList.Count - 1 do begin if i <> 0 then Result := Result + ', '; Result := Result + IntToStr(AIDList[i]); end; Result := Result + ')) '; end; end; if (APreviosConditions <> '') and (Result <> '') then Result := APreviosConditions + ' and '+ Result else if Result = '' then Result := APreviosConditions; end; function GetStrFieldType(AFieldType: TFieldType; ASize: Integer): String; var StrSize: Integer; begin Result := ''; StrSize := ASize; if StrSize < 0 then StrSize := 255; case AFieldType of ftBlob: Result := 'BLOB SUB_TYPE 0 SEGMENT SIZE 80'; ftDate: Result := 'DATE'; ftInteger: Result := 'INTEGER'; ftFloat: Result := 'FLOAT'; ftSmallint: Result := 'SMALLINT'; ftString: Result := 'VARCHAR('+IntToStr(StrSize)+')'; ftTime: Result := 'TIME'; end; end; function GenIDFromTable(AQSelect: TpFIBQuery; const AGeneratorName: String; AIncr: Integer): Integer; var strSQL: String; begin Result := 0; if Assigned(AQSelect) then begin strSQL := 'SELECT GEN_ID('+AGeneratorName+', '''+IntToStr(AIncr)+''') as '+fnID+' FROM '+tnRDBDatabase+''; AQSelect.Close; if AQSelect.SQL.Text <> strSQL then AQSelect.SQL.Text := strSQL; AQSelect.ExecQuery; //Result := AQSelect.FN(fnID).AsInteger; Result := AQSelect.Fields[0].AsInteger; AQSelect.Close; end; end; function GetFileStreamFromTableByID(ATableName, AFieldName, ATrgFile: String; AID: Integer; AQuery: TpFIBQuery): TFileStream; var StreamSize: Integer; begin Result := nil; AQuery.Options := AQuery.Options + [qoFreeHandleAfterExecute]; SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, ATableName, fnID+' = '''+IntToStr(AID)+''' ', nil, AFieldName)); AQuery.FN(AFieldName).SaveToFile(ATrgFile); AQuery.Close; Result := TFileStream.Create(ATrgFile, fmOpenRead); Result.Position := 0; StreamSize := Result.Size; Result.Position := 0; end; function GetIntFromTableByGUID(ATableName, AResFieldName, AGUID: String; AQuery: TpFIBQuery): Integer; var ValRes: Variant; begin Result := -1; ValRes := GetValueFromTable(ATableName, AResFieldName, fnGUID, AGUID, AQuery); if ValRes <> null then Result := ValRes; end; function GetIntFromTableByID(ATableName, AResFieldName: String; AID: Integer; AQuery: TpFIBQuery): Integer; var ValRes: Variant; begin Result := -1; ValRes := GetValueFromTable(ATableName, AResFieldName, fnID, AID, AQuery); if ValRes <> null then Result := ValRes; end; function GetIntFromTableByFld(const ATableName, AField, AResFieldName, AVal: String; AQuery: TpFIBQuery): Integer; var ValRes: Variant; begin Result := -1; ValRes := GetValueFromTable(ATableName, AResFieldName, AField, AVal, AQuery); if ValRes <> null then Result := ValRes; end; function GetStreamFromTableByID(ATableName, AFieldName: String; AID: Integer; AQuery: TpFIBQuery): TMemoryStream; var StreamSize: Integer; begin Result := TMemoryStream.Create; Result.Position := 0; SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, ATableName, fnID+' = '''+IntToStr(AID)+''' ', nil, AFieldName)); AQuery.FN(AFieldName).SaveToStream(Result); { Result.Free; Result := TMemoryStream.Create; Result.Position := 0; AQuery.FN(AFieldName).SaveToStream(Result); } AQuery.Close; StreamSize := Result.Size; Result.Position := 0; end; function GetStringFromStream(AStream: TStream): String; var StringStream: TStringStream; begin Result := ''; if (AStream <> nil) and (AStream.Size > 0) then begin StringStream := TStringStream.Create(''); StringStream.CopyFrom(AStream, 0); StringStream.Position := 0; Result := StringStream.DataString; StringStream.Free; end; end; function GetStringFromTableByGUID(ATableName, AFieldName, AGUID: String; AQuery: TpFIBQuery): String; var ValRes: Variant; begin Result := ''; ValRes := GetValueFromTable(ATableName, AFieldName, fnGUID, AGUID, AQuery); if ValRes <> null then Result := ValRes; end; function GetStringFromTableByID(ATableName, AFieldName: String; AID: Integer; AQuery: TpFIBQuery): String; var ValRes: Variant; begin Result := ''; ValRes := GetValueFromTable(ATableName, AFieldName, fnID, AID, AQuery); if ValRes <> null then Result := ValRes; end; function GetTableFieldsNames(ATableName: String; AQuery: TpFIBQuery): TStringList; var i: Integer; begin Result := TStringList.Create; SetSQLToFIBQuery(AQuery, 'select * from '+ATableName+' where id = ''0'' '); for i := 0 to AQuery.FieldCount - 1 do Result.Add(AQuery.Fields[i].Name); end; function GetTableIndexByGeneratorIndex(AGeneratorIndex: Integer): Integer; begin Result := 0; case AGeneratorIndex of giKatalogID, giKatalogSCSID: Result := tiKatalog; giCatalogRelationID: Result := tiCatalogRelation; giComponentID, giComponentWholeID: Result := tiComponent; giCatalogMarkMaskID: Result := tiCatalogMarkMask; giCatalogPropRelationID: Result := tiCatalogPropRelation; giComponentRelationID: Result := tiComponentRelation; giCompPropRelationID: Result := tiCompPropRelation; giCableCanalConnectorsID: Result := tiCableCanalConnectors; giConnectedComponentsID: Result := tiConnectedComponents; giInterfaceRelationID: Result := tiInterfaceRelation; giInterfOfInterfRelationID: Result := tiInterfOfInterfRelation; giPortInterfaceRelationID: Result := tiPortInterfaceRelation; giNormsID: Result := tiNorms; giNormResourceRelID: Result := tiNormResourceRel; giResourcesID: Result := tiResources; end; end; function GetTableNameByGeneratorIndex(AGeneratorIndex: Integer): String; var TableIndex: Integer; begin Result := ''; TableIndex := GetTableIndexByGeneratorIndex(AGeneratorIndex); Result := GetTableNameByTableIndex(TableIndex); end; function GetTableNameByGUIDFieldPointer(AGUIDFieldPointer: String): String; begin Result := ''; if AGUIDFieldPointer = fnGuidComponentType then Result := tnComponentTypes else if AGUIDFieldPointer = fnGuidInterface then Result := tnInterface else if AGUIDFieldPointer = fnGuidNBConnector then Result := tnComponent else if AGUIDFieldPointer = fnGuidNetType then Result := tnNetType else if AGUIDFieldPointer = fnGuidObjectIcon then Result := tnObjectIcons else if AGUIDFieldPointer = fnGuidProducer then Result := tnProducers else if AGUIDFieldPointer = fnGuidProperty then Result := tnProperties else if AGUIDFieldPointer = fnGuidSuppliesKind then Result := tnSuppliesKinds else if AGUIDFieldPointer = fnGuidSupplier then Result := tnSupplier else if AGUIDFieldPointer = fnGuidSymbol then Result := tnObjectIcons; end; function GetTableNameByTableIndex(ATableIndex: Integer): String; begin Result := ''; case ATableIndex of tiComponentTypes: Result := tnComponentTypes; tiNetType: Result := tnNetType; tiObjectIcons: Result := tnObjectIcons; tiProducer: Result := tnProducers; tiSupplier: Result := tnSupplier; tiSuppliesKind: Result := tnSuppliesKinds; tiProperties: Result := tnProperties; tiKatalog: Result := tnCatalog; tiCatalogRelation: Result := tnCatalogRelation; tiComponent: Result := tnComponent; tiCatalogMarkMask: Result := tnCatalogMarkMask; tiCatalogPropRelation: Result := tnCatalogPropRelation; tiComponentRelation: Result := tnComponentRelation; tiCompPropRelation: Result := tnCompPropRelation; tiCableCanalConnectors: Result := tnCableCanalConnectors; tiConnectedComponents: Result := tnConnectedComponents; tiInterfaceRelation: Result := tnInterfaceRelation; tiInterfOfInterfRelation: Result := tnInterfOfInterfRelation; tiPortInterfaceRelation: Result := tnPortInterfaceRelation; tiNorms: Result := tnNorms; tiNormResourceRel: Result := tnNormResourceRel; tiResources: Result := tnResources; tiNBNorms: Result := tnNBNorms; tiNBResources: Result := tnNBResources; end; end; function GetTablesFromBase(AQSelect: TpFIBQuery): TStringList; begin Result := TStringList.Create; SetSQLToFIBQuery(AQSelect, 'select rdb$relation_name from rdb$relations '+ 'where (rdb$system_flag = 0) and (rdb$view_source is null)'+ 'order by rdb$relation_name asc '); while Not AQSelect.Eof do begin Result.Add(AQSelect.FN('rdb$relation_name').AsString); AQSelect.Next; end; end; function GetTimeUOMName(const aVal: Integer): String; begin Result := ''; if aVal = tuMin then Result := cBaseCommon85_2 else Result := cBaseCommon85_1; end; function GetValueFromTable(ATableName, AResFieldName, AFldBy: String; AFldValue: Variant; AQuery: TpFIBQuery): Variant; var strFilter: String; strValue: String; begin Result := null; strValue := AFldValue; strFilter := AFldBy+' = '''+strValue+''''; AQuery.Close; AQuery.SQL.Text := 'select '+AResFieldName+' from '+ATableName+' '+ 'where '+strFilter; AQuery.ExecQuery; Result := AQuery.FN(AResFieldName).Value; AQuery.Close; end; function GetValueFromTableFirst(ATableName, AResFieldName: String; AQuery: TpFIBQuery): Variant; begin Result := null; SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, ATableName, '', nil, fnFirst1+' '+AResFieldName)); if AQuery.RecordCount > 0 then Result := AQuery.Fields[0].Value; end; procedure IntFIBFieldToIntList(AIntList: TObject; AQuery: TpFIBQuery; const AFieldName: String); var FieldIndex: integer; begin FieldIndex := AQuery.FieldIndex[AFieldName]; while Not AQuery.Eof do begin //GetMem(ptrValue, SizeOf(Integer)); //ptrValue^ := AQuery.FN(AFieldName).AsInteger; //TIntList(AIntList).Add(AQuery.FN(AFieldName).AsInteger); TIntList(AIntList).Add(AQuery.Fields[FieldIndex].AsInteger); AQuery.Next; end; end; procedure StrFIBFieldToStringList(AStringList: TStringList; AQuery: TpFIBQuery; const AFieldName: String); var FieldIndex: integer; begin FieldIndex := AQuery.FieldIndex[AFieldName]; while Not AQuery.Eof do begin AStringList.Add(AQuery.Fields[FieldIndex].AsString); AQuery.Next; end; end; // ##### Сохранить поле в поток ##### procedure SaveToStreamFromQr(var AQuery: TpFIBQuery; var AStream: TStream; AFieldName: String; ACreateStream: Boolean); begin if ACreateStream then AStream := TMemoryStream.Create; AStream.Position := 0; AQuery.FN(AFieldName).SaveToStream(AStream); AStream.Position := 0; end; procedure SaveToStreamFromSQLMT(AMemTable: TSQLMemTable; AStream: TStream; AFieldName: String); begin AStream.Position := 0; TBLobField(AMemTable.FieldByName(AFieldName)).SaveToStream(AStream); AStream.Position := 0; end; procedure SaveToStringListFromQr(AQuery: TpFIBQuery; AStringList: TStringList; AFieldName: String; AUnPack: Boolean); var Stream: TMemoryStream; UnPackedStream: TMemoryStream; begin Stream := TMemoryStream.Create; SaveToStreamFromQr(AQuery, TStream(Stream), AFieldName, false); if AUnPack then begin UnPackedStream := TMemoryStream.Create; UnPakStream(Stream, UnPackedStream); UnPackedStream.Position := 0; ExchangeObjects(Stream, UnPackedStream); FreeAndNil(UnPackedStream); end; AStringList.LoadFromStream(Stream); FreeAndNil(Stream); end; procedure SetBusyParamsToBase(AQSelect, AQOperat: TpFIBQuery; ABusyType: Integer); var BaseNow: TDateTime; begin DefineBusyFieldsInBase(AQSelect, AQOperat); if ABusyType = bbmEmpty then begin UpdateTableFieldAllRec(AQOperat, tnSettings, fnBusyDate, null); UpdateTableFieldAllRec(AQOperat, tnSettings, fnBusyTime, null); end else begin BaseNow := GetBaseNow(AQSelect); UpdateTableFieldAllRec(AQOperat, tnSettings, fnBusyDate, BaseNow); UpdateTableFieldAllRec(AQOperat, tnSettings, fnBusyTime, BaseNow); end; UpdateTableFieldAllRec(AQOperat, tnSettings, fnBusyType, ABusyType); end; procedure SetFieldInfo(const ATableName, AFieldName, AParamName: String; AValue: Variant; AQSelect, AQOperat: TpFIBQuery); var FieldSource: String; begin try SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, 'RDB$RELATION_FIELDS', '(RDB$RELATION_NAME = '''+ATableName+''') AND (RDB$FIELD_NAME = '''+AFieldName+''')', nil, 'RDB$FIELD_SOURCE')); if AQSelect.RecordCount > 0 then begin FieldSource := AQSelect.Fields[0].AsString; if FieldSource <> '' then begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, 'RDB$FIELDS', 'RDB$FIELD_NAME = '''+FieldSource+'''', nil, AParamName), false); AQOperat.Params[0].Value := AValue; AQOperat.ExecQuery; //SetSQLToFIBQuery(AQSelect, GetSQLByParams(qtSelect, 'RDB$FIELDS', 'RDB$FIELD_NAME = '''+FieldSource+'''', nil, AParamName)); //while Not AQSelect.Eof do //begin // //AQSelect.Fields[0].AsString; // AQSelect.Next; //end; end; end; except on E: Exception do AddExceptionToLogEx('SetFieldPositionInTable', E.Message); end; end; procedure SetFieldPositionInTable(ATableName, AFieldName: String; APosition: Integer; AQOperat: TpFIBQuery); begin try SetSQLToFIBQuery(AQOperat, 'alter table '+ATableName+' alter column '+AFieldName+' position '+IntToStr(APosition)); except on E: Exception do AddExceptionToLogEx('SetFieldPositionInTable', E.Message); end; end; procedure SetNBType(ANBType: Integer; AQSelect, AQOperat: TpFIBQuery); begin try if Not CheckFieldInTable(tnGradeGrid, fnDescription, AQSelect) then AddFieldToTable(tnGradeGrid, fnDescription, ftString, nbtGeneral, AQOperat); raise Exception.Create(''); except SetFieldInfo(tnGradeGrid, fnDescription, StringReverse('HTGNEL_DLEIF$BDR'), ANBType*nbTypeKoeff, AQSelect, AQOperat); SetFieldInfo(tnGradeGrid, fnDescription, StringReverse('HTGNEL_RETCARAHC$BDR'), ANBType*nbTypeKoeff, AQSelect, AQOperat); end; end; function GetDayKolvo(Query_Select: TpFIBQuery): integer; begin Result := 0 XOR $1A; GetFieldInfo(tnGradeGrid, 'DESCR', Query_Select); if Query_Select.RecordCount > 0 then Result := Trunc(Query_Select.FN(StringReverse('HTGNEL_DLEIF$BDR')).AsInteger / nbTypeKoeff); end; procedure SetDayKolvo(Kolvo: Integer; AQSelect, AQOperat: TpFIBQuery); begin try if Not CheckFieldInTable(tnGradeGrid, 'DESCR', AQSelect) then AddFieldToTable(tnGradeGrid, 'DESCR', ftString, 0 XOR $1A, AQOperat); raise Exception.Create(''); except SetFieldInfo(tnGradeGrid, 'DESCR', StringReverse('HTGNEL_DLEIF$BDR'), Kolvo*nbTypeKoeff, AQSelect, AQOperat); SetFieldInfo(tnGradeGrid, 'DESCR', StringReverse('HTGNEL_RETCARAHC$BDR'), Kolvo*nbTypeKoeff, AQSelect, AQOperat); end; end; procedure SetParamAsBufferToQuery(AQuery: TpFIBQuery; AFldName: String; var ABuffer; ABuffSize: Integer); var Stream: TStream; begin Stream := TMemoryStream.Create; Stream.WriteBuffer(ABuffer, ABuffSize); Stream.Position := 0; SetParamAsStreamToQuery(AQuery, AFldName, Stream); Stream.Free; end; procedure SetParamAsInteger0AsNullToQuery(AQuery: TpFIBQuery; AFldName: String; AValue: Integer); begin if AValue = 0 then AQuery.ParamByName(AFldName).AsVariant := Null else AQuery.ParamByName(AFldName).AsInteger := AValue; end; procedure SetParamAsStreamToQuery(AQuery: TpFIBQuery; const AFldName: String; AValue: TStream; APack: Boolean=false); var StreamSize: Integer; PackedStream: TMemoryStream; begin PackedStream := nil; StreamSize := AValue.Size; if APack then begin PackedStream := TMemoryStream.Create; AValue.Position := 0; //PakStream(AValue, PackedStream, aCompLevel); PakStream(AValue, PackedStream); AValue := PackedStream; end; AValue.Position := 0; StreamSize := AValue.Size; AQuery.ParamByName(AFldName).LoadFromStream(AValue); AValue.Position := 0; if PackedStream <> nil then FreeAndNil(PackedStream); end; procedure SetParamAsStringEmptyAsNullToQuery(AQuery: TpFIBQuery; const AFldName, AValue: String); begin if AValue = '' then AQuery.ParamByName(AFldName).Value := Null else AQuery.ParamByName(AFldName).AsString := AValue; end; procedure SetParamAsStringListToQuery(AQuery: TpFIBQuery; const AFldName: String; AStringList: TStrings; APack: Boolean); var Stream: TMemoryStream; //PackedStream: TMemoryStream; begin try Stream := TMemoryStream.Create; AStringList.SaveToStream(Stream); //if APack then //begin // PackedStream := TMemoryStream.Create; // Stream.Position := 0; // PakStream(Stream, PackedStream); // ExchangeObjects(Stream, PackedStream); // FreeAndNil(PackedStream); //end; SetParamAsStreamToQuery(AQuery, AFldName, Stream, APack); FreeAndNil(Stream); except on E: Exception do AddExceptionToLogEx('SetParamAsStringListToQuery', E.Message); end; end; procedure CopyStream(ADest, ASrc: TStream); var SrcStreamSize: Integer; begin ASrc.Position := 0; SrcStreamSize := ASrc.Size; if ADest is TMemoryStream then TMemoryStream(ADest).Clear; ADest.Position := 0; ADest.CopyFrom(ASrc, 0); ADest.Position := 0; ASrc.Position := 0; SrcStreamSize := ASrc.Size; end; function SafeOpenFileStream(AFilePath: string; AMode: Word; AProcedureName: string=''; AMsgIfFail: String=''): TFileStream; var CanTryOpenFile: Boolean; FailOpenFileCount: Integer; TimeOut: Integer; //Tolik 28/08/2019 - - //FirstTick, CurrTick: Cardinal; FirstTick, CurrTick: DWord; // MessgStr: string; begin Result := nil; //if (AMode = fmCreate) or // (AMode = fmOpenRead) or // (AMode = fmOpenWrite) or // (AMode = fmOpenReadWrite) then begin TimeOut := 9000; FirstTick := GetTickCount; CanTryOpenFile := true; FailOpenFileCount := 0; while CanTryOpenFile do begin CanTryOpenFile := false; try Result := TFileStream.Create(AFilePath, AMode); except on E: Exception do begin Result := nil; CanTryOpenFile := true; Inc(FailOpenFileCount); end; end; // TimeOut CurrTick := GetTickCount; if Abs(CurrTick - FirstTick) > TimeOut then Break; //// BREAK //// end; if FailOpenFileCount > 0 then begin MessgStr := 'File '+AFilePath; if Result = nil then MessgStr := MessgStr + ' NOT'; MessgStr := MessgStr + ' opened after fail access (try count = '+IntToStr(FailOpenFileCount)+')'; AddExceptionToLogEx(AProcedureName, MessgStr); //if Result <> nil then // AddExceptionToLogEx(AProcedureName, 'File '+AFilePath+' opened after fail access (try count = '+IntToStr(FailOpenFileCount)+')') //else // AddExceptionToLogEx(AProcedureName, 'File '+AFilePath+' NOT opened after fail access (try count = '+IntToStr(FailOpenFileCount)+')'); end; end; if (Result = nil) and (AMsgIfFail <> '') then AddExceptionToLog(AMsgIfFail, true); end; procedure OpenBaseResultHandler(AOpenBaseResult: TOpenBaseResult; AForm: TForm; ACanReconnect, ACanExitProc: Boolean; aConnType: integer = 0); var HaltMessgIconType: Integer; OpenMessage: String; BaseName: String; CanExitProcess: Boolean; OpenBaseResult: TOpenBaseResult; CanWhile: Boolean; CanUpdate: Boolean; UpdateFileName: String; begin CanExitProcess := false; OpenBaseResult := AOpenBaseResult; UpdateFileName := ''; with TF_Main(AForm) do begin CanWhile := true; while CanWhile do begin CanWhile := false; case OpenBaseResult of obrSuccess: GConnected := true; //obrNoBases, obrNoProperBases, obrInUse, obrRemoteBases: else begin HaltMessgIconType := 0; OpenMessage := ''; BaseName := ''; case GDBMode of bkNormBase: BaseName := cOfNormBase; bkProjectManager: BaseName := cOfProjMan; end; case OpenBaseResult of obrFoul: begin OpenMessage := cErrorBaseOpen + ' " '+GSCSBase.DBName+'".'; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; {$IF Defined(FLASH_SCS)} if GDBMode = bkNormBase then begin if aConnType = 2 then begin OpenMessage := 'Не возможно подключиться к серверу.'+ #13#10 + 'Будет произведена попытка локального подключения.'; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; TF_Main(AForm).GSCSBase.OpenErrorMessage := ''; end; end; {$IFEND} end; obrNoBases: begin OpenMessage := cNowExistsFileOfBase+' '+BaseName; OpenMessage := OpenMessage + '" '+GSCSBase.DBName+'".'; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; end; obrOldStructure: begin OpenMessage := cFileOf+' '+BaseName+' '+cFileOfBaseHaveOldStructure+' '+GSCSBase.DBName+'.'+#10+#13+ cQuastStartUpdate; HaltMessgIconType := MB_ICONQUESTION or MB_YESNO; end; obrNoProperBases: begin OpenMessage := cFileOf+' "'+GSCSBase.DBName+'" '+cFileIsNotFileOf+' '+BaseName+'/'; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; end; //obrRemoteBases: // begin // OpenMessage := 'Загрузка баз из сети не предусмотрена. '+ // ' Требуется скопировать базы на локальный диск и открыть их оттуда самостоятельно.'; // HaltMessgIconType := MB_ICONSTOP or MB_YESNO; // end; obrInUse: begin OpenMessage := cFileOf+' '+BaseName+' "'+GSCSBase.DBName+'" '+cFileIsUseByOtherApplication; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; end; obrBusyMode: begin case TF_Main(AForm).GSCSBase.BusyType of bbmUpdate: OpenMessage := cBaseCommon41_2 +' '+ cBaseCommon41_1; bbmExportData: OpenMessage := cBaseCommon41_3 +' '+ cBaseCommon41_1; bbmImportData: OpenMessage := cBaseCommon41_4 +' '+ cBaseCommon41_1; bbmPack: OpenMessage := cFileOf+' '+BaseName+' '+cBaseCommon41_5 +'. '+ cBaseCommon41_1; bbmBackUp: OpenMessage := cFileOf+' '+BaseName+' '+cBaseCommon41_6 +'. '+ cBaseCommon41_1; end; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; end; obrFailProgramBaseType: begin OpenMessage := ''; if GDBMode = bkNormBase then OpenMessage := cBaseCommon41_7 else if GDBMode = bkProjectManager then OpenMessage := cBaseCommon41_8; HaltMessgIconType := MB_ICONSTOP or MB_YESNO; end; end; if (OpenMessage <> '') and (TF_Main(AForm).GSCSBase.OpenErrorMessage <> '') then OpenMessage := OpenMessage +#10+#13+ TF_Main(AForm).GSCSBase.OpenErrorMessage; if OpenBaseResult in [obrFoul, obrNoBases, obrNoProperBases, obrInUse, obrBusyMode, obrFailProgramBaseType] then begin if TF_Main(AForm).GDBMode = bkNormBase then MessageModal(OpenMessage, cOpeningBases, MB_OK or MB_ICONSTOP); if TF_Main(AForm).GDBMode = bkProjectManager then begin if ACanReconnect then OpenMessage := OpenMessage +#10+#13+ cQuastTryOpenBaseManually else HaltMessgIconType := MB_OK or MB_ICONSTOP; if MessageModal(OpenMessage, cOpeningBases, HaltMessgIconType) = ID_YES then begin if F_Connect = nil then //04.01.2011 F_Connect := TF_Connect.Create(AForm, TForm(AForm)); if Not F_Connect.Execute(bkProjectManager, false) then CanExitProcess := true; end else begin CanExitProcess := true; end; end; end else if OpenBaseResult in [obrOldStructure] then begin if F_Animate = nil then F_Animate := TF_Animate.Create(AForm); CanUpdate := false; UpdateFileName := ''; //*** попытаться обновиться из файла, указаном в Update.ini UpdateFileName := ReadUpdatePath; if UpdateFileName <> '' then CanUpdate := true else if MessageModal(OpenMessage, cOpeningBases, HaltMessgIconType) = ID_YES then CanUpdate := true; if CanUpdate then begin if Not UpdateNB(F_NormBase.GSCSBase.DBName, true, UpdateFileName) then CanExitProcess := true else begin {//30.03.2009 if GSCSBase.Active then GSCSBase.Close; OpenBaseResult := GSCSBase.Open(GSCSBase.DBName, true, false); GSCSBase.SimpleClose(false); // Выкинуть потч обновлением if OpenBaseResult = obrSuccess then WriteUpdatePath(''); CanWhile := true; } // Если локальное подключение, то просим перезапустить программу if CheckIsLicalPath(GSCSBase.DBName) then begin MessageModal(cBaseCommon56, ApplicationName, MB_OK); // Выкинуть потч обновлением WriteUpdatePath(''); //WinExec(PChar(Application.ExeName), SW_SHOW); // принужденное завершение программы не учитвая флаг ACanExitProc //25.09.2010 {$if Defined(ES_GRAPH_SC)} // Application.Terminate; //{$else} // ExitProcess(0); //{$ifend} ReloadProgram; end else begin if GSCSBase.Active then GSCSBase.Close; OpenBaseResult := GSCSBase.Open(GSCSBase.DBName, true, false); GSCSBase.SimpleClose(false); // Выкинуть потч обновлением if OpenBaseResult = obrSuccess then WriteUpdatePath(''); CanWhile := true; end; end; end else begin CanExitProcess := true; end; end; end; end; end; if CanExitProcess then begin CanExitProcess := false; GConnected := false; if ACanExitProc then {$if Defined(ES_GRAPH_SC)} Application.Terminate; {$else} ExitProcess(0); {$ifend} //Halt; Exit; end else GConnected := true; end; end; procedure UpdateNormBaseResultHandler(AUpdateReults: TUpdateBaseResults; ASrcPath: String); var ResMsg: String; begin ResMsg := ''; if ubrSuccessful in AUpdateReults then begin ResMsg := cBasesUpdatesuccessful; end else begin if ubrTrgBaseNotExist in AUpdateReults then ResMsg := ResMsg + '- '+cNoFindedUpdatingBase+'.'+ #10+#13; if ubrSrcBaseNotExist in AUpdateReults then ResMsg := ResMsg + '- '+cNoFindedUpdateSrcFile+'.'+ #10+#13; if ubrTrgBaseOpenError in AUpdateReults then ResMsg := ResMsg + '- '+cNoOpenUpdatingBase+'.'+ #10+#13; if ubrSrcBaseOpenError in AUpdateReults then ResMsg := ResMsg + '- '+cNoOpenUpdateSrcFile+'.'+ #10+#13; if ubrSameBases in AUpdateReults then ResMsg := ResMsg + '- '+cbMessage8+'.'; if ubrSrcIsNoNB in AUpdateReults then ResMsg := ResMsg + '- '+cNameFile+' "'+ASrcPath+'" '+cFileIsNotFileOfNormBase+'.'; if ResMsg <> '' then ResMsg := cbMessage9+':'+ #10+#13 + ResMsg; end; if ResMsg <> '' then MessageModal(ResMsg, ApplicationName, MB_OK or MB_ICONINFORMATION); end; function LoadBufferFromFile(var ABuffer; ASize: Integer; AFileName: string): Boolean; var FileStream: TFileStream; SizeToRead: integer; StreamSize: integer; begin //FileStream := TFileStream.Create(AFileName, fmOpenRead); FileStream := SafeOpenFileStream(AFileName, fmOpenRead, 'LoadBufferFromFile'); Result := FileStream <> nil; if Result then begin StreamSize := FileStream.Size; SizeToRead := ASize; if StreamSize < SizeToRead then SizeToRead := StreamSize; FileStream.ReadBuffer(ABuffer, ASize); FreeAndNil(FileStream); end; end; procedure LoadFromStreamToMT(AMemTable: TkbmMemTable; AStream: TStream; const AFieldName: String); begin AStream.Position := 0; TBLobField(AMemTable.FieldByName(AFieldName)).LoadFromStream(AStream); AStream.Position := 0; end; // ##### Загрузить в поле из потока ##### procedure LoadFromStreamToQr(var AQuery: TpFIBQuery; var AStream: TStream; AParamName: String; AFreeStream: Boolean); begin AStream.Position := 0; AQuery.ParamByName(AParamName).LoadFromStream(AStream); if AFreeStream then FreeAndNil(AStream); end; procedure LoadFromStreamToSQLMT(AMemTable: TSQLMemTable; AStream: TStream; AFieldName: String); begin AStream.Position := 0; TBLobField(AMemTable.FieldByName(AFieldName)).LoadFromStream(AStream); AStream.Position := 0; end; procedure LoadMTFromFIBQuery(AMT: TkbmMemTable; AQSelect: TpFIBQuery); var FieldList: TStringList; FName: String; QSelectField: TFIBXSQLVAR; BufStram: TStream; i: Integer; begin FieldList := TStringList.Create; for i := 0 to AQSelect.FieldCount - 1 do begin FName := AQSelect.Fields[i].Name; if AMT.FieldDefs.IndexOf(FName) <> -1 then FieldList.Add(FName); end; while Not AQSelect.Eof do begin AMT.Append; for i := 0 to FieldList.Count - 1 do begin FName := FieldList[i]; QSelectField := AQSelect.FN(FName); if QSelectField.SQLType = SQL_BLOB then begin SaveToStreamFromQr(AQSelect, BufStram, FName, true); LoadFromStreamToMT(AMT, BufStram, FName); FreeAndNil(BufStram); end else AMT.FieldByName(FName).Value := QSelectField.Value; end; AMT.Post; AQSelect.Next; end; FieldList.Free; end; function SaveBlobFieldToFile(ATableName, AFieldName, ATrgFile: String; AID: Integer; AQuery: TpFIBQuery): Boolean; var StreamSize: Integer; begin Result := false; if FileExists(ATrgFile) then DeleteFile(ATrgFile); if Not FileExists(ATrgFile) then begin SetSQLToFIBQuery(AQuery, GetSQLByParams(qtSelect, ATableName, fnID+' = '''+IntToStr(AID)+''' ', nil, AFieldName)); AQuery.FN(AFieldName).SaveToFile(ATrgFile); AQuery.Close; if FileExists(ATrgFile) then Result := true; end; end; procedure SaveBufferToFile(var ABuffer; ASize: Integer; AFileName: string); var FileStream: TFileStream; begin FileStream := TFileStream.Create(AFileName, fmCreate); FileStream.WriteBuffer(ABuffer, ASize); FreeAndNil(FileStream); end; procedure SaveToStreamFromMT(AMemTable: TkbmMemTable; AStream: TStream; AFieldName: String); begin AStream.Position := 0; TBLobField(AMemTable.FieldByName(AFieldName)).SaveToStream(AStream); AStream.Position := 0; end; procedure SetSQLToFIBQuery(AQuery: TpFIBQuery; const ASQL: String; AExecute: Boolean); begin if Assigned(AQuery) then begin AQuery.Close; AQuery.SQL.Clear; AQuery.SQL.Text := ASQL; if AExecute then AQuery.ExecQuery; end; end; procedure SetSQLToFIBQueryWithCheckSQL(AQuery: TpFIBQuery; ASQL: String; AExecute: Boolean = true); begin if Assigned(AQuery) then begin AQuery.Close; if AQuery.SQL.Text <> ASQL then AQuery.SQL.Text := ASQL; if AExecute then AQuery.ExecQuery; end; end; // Tolik 31/01/2020 Здесь была попытка сбросить системный кеш таблиц..... может быть, // не совсем удачная, т.к. есть подозрения, что такая реализация крупно периодически подсирает.... // нужно подыбать ... (* procedure SetStreamToTableByID(ATableName, AFieldName: String; AID: Integer; AStream: TStream; AQOperat: TpFIBQuery); var Size: Integer; oldSql: string; vt: TVarType; begin AStream.Position := 0; Size := AStream.Size; SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, fnID+' = '''+IntToStr(AID)+'''', nil, AFieldName), false); // AQOperat.Prepare; //AQOperat.ParamCheck := False; //AQOperat.ParamByName(AFieldName).LoadFromStream(AStream); AQOperat.Params[0].LoadFromStream(AStream); // Tolik 10/05/2019 -- так низзя, ебается //AQOperat.ParamCheck := False; // AQOperat.ExecQuery; //AQOperat.Params.ClearValues; //AQOperat.Params[0].Clear; //AQOperat.Params[0].Free; //низя //SetLength(AQOperat.Params[0].OldValue, 0); //VarClear(AQOperat.Params[0].OldValue); //FreeMem( TVarData(AQOperat.Params[0].OldValue).VString); vt := VarType(AQOperat.Params[0].OldValue); //(AQOperat.Params[0].OldValue); // AQOperat.Params[0].OldValue; - нужно фрикнуть { for j :=0 to Pred(AQOperat.Params.Count) do begin b:=FXSQLVARs^[j].IsNullable; FXSQLVARs^[j].IsNull:=True; FXSQLVARs^[j].IsNullable:=b; end; } AQOperat.Params[0].CleanupInstance; AQOperat.Close; oldSQL := AQOperat.SQL.Text; AQOperat.SQL.Text := 'update katalog set id = 1 where id = ?id'; AQOperat.Params[0].Value := 1; AQOperat.ExecQuery; AQOperat.SQL.Text := oldSQL; AQOperat.Prepare; AStream.Position := 0; end; *) procedure SetStreamToTableByID(ATableName, AFieldName: String; AID: Integer; AStream: TStream; AQOperat: TpFIBQuery); var Size: Integer; begin AStream.Position := 0; Size := AStream.Size; SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, fnID+' = '''+IntToStr(AID)+'''', nil, AFieldName), false); AQOperat.ParamByName(AFieldName).LoadFromStream(AStream); AQOperat.ExecQuery; AQOperat.Close; AStream.Position := 0; end; procedure StoreGuidsInReservGuidTable(ADataBase: TpFIBDataBase; AReservGuidSize: Integer); var // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // i: Integer; CurrReservGuidSize: Integer; FQuery: TpFIBQuery; FTransaction: TpFIBTransaction; ReservGuidSizeToSet: Integer; begin //if ADataBase.Connected then begin CurrReservGuidSize := 0; ReservGuidSizeToSet := AReservGuidSize; if ReservGuidSizeToSet < ReservGuidSize then ReservGuidSizeToSet := ReservGuidSize; //*** Определить тек-е кол-во Гуидов в таблице FQuery := TpFIBQuery.Create(nil); FTransaction := TpFIBTransaction.Create(nil); try FQuery.Database := ADataBase; FQuery.Transaction := FTransaction; FQuery.GoToFirstRecordOnExecute := true; FQuery.Options := [qoStartTransaction]; FTransaction.DefaultDatabase := ADataBase; OldTick := GetTickCount; SetSQLToFiBQuery(FQuery, GetSQLByParams(qtSelect, tnReservGuid, '', nil, fnCount+'('+fnID+')')); if FQuery.RecordCount > 0 then CurrReservGuidSize := FQuery.Fields[0].AsInteger; FQuery.Close; //*** Добавить недостающие записи if CurrReservGuidSize < ReservGuidSizeToSet then begin //*** Если остался последний гуид, который мог быть использован несколько раз, то нужно его удалить if CurrReservGuidSize = 1 then begin FQuery.Transaction.StartTransaction; SetSQLToFIBQuery(FQuery, GetSQLByParams(qtDelete, tnReservGuid, '', nil, ''), false); FQuery.ExecQuery; FQuery.Transaction.Commit; FQuery.Close; CurrReservGuidSize := 0; end; //*** Закинуть недостающие гуиды FQuery.Transaction.StartTransaction; SetSQLToFIBQuery(FQuery, GetSQLByParams(qtInsert, tnReservGuid, '', nil, fnGuid), false); for i := 0 to (ReservGuidSizeToSet - CurrReservGuidSize) - 1 do begin //Query_Operat.Close; FQuery.Params[0].AsString := CreateGUID; FQuery.ExecQuery; end; FQuery.Transaction.Commit; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; finally FTransaction.Active := false; FQuery.Transaction := nil; FreeAndNil(FQuery); FreeAndNil(FTransaction); end; { SetSQLToFIBQuery(Query_Operat, GetSQLByParams(qtInsert, tnReservGuid, '', nil, fnGuid), false); OldTick := GetTickCount; Query_Operat.Options := Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try Query_Operat.Transaction.StartTransaction; for i := 0 to ReservGuidSize - 1 do begin //Query_Operat.Close; Query_Operat.Params[0].AsString := CreateGUID; Query_Operat.ExecQuery; end; Query_Operat.Transaction.Commit; finally Query_Operat.Close; Query_Operat.Options := Query_Operat.Options + [qoAutoCommit, qoStartTransaction]; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick;} end; end; function TextToOEM(const aText: AnsiString): String; // Tolik 04/04/2019 -- не юзается ниде ... var StrOEM: PChar; begin // Tolik 21/06/2019 -- //GetMem(StrOEM, Length(aText)); GetMem(StrOEM, (Length(aText) + 1)*2); // AnsiToOem(PAnsiChar(aText), PAnsiChar(StrOEM)); Result := StrOEM; end; function TextToUTF16LE(const aText: String): String; var i:byte; UniC:PWideChar; Res:WideString; begin {Res := ''; i:=length(aText); new(UniC); while i>0 do begin StringToWideChar(aText[i],UniC,2); Res:=UniC^+Res; dec(i); end; Dispose(UniC);} Result := ''; for i := 1 to Length(aText) do begin Result := Result + #0 + aText[i]; end; end; procedure UpdateTableFieldAllRec(AQOperat: TpFIBQuery; ATableName, AUpdFieldName: String; ANewValue: Variant); begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, '', nil, AUpdFieldName), false); AQOperat.ParamByName(AUpdFieldName).Value := ANewValue; AQOperat.ExecQuery; AQOperat.Close; end; procedure UpdateTableIntFieldRecsFromListID(AQOperat: TpFIBQuery; const ATableName, AUpdFieldName: String; ANewValue: Variant; ASrcIDList: TIntList); var i: integer; SavedQOperatOptions: TpFIBQueryOptions; begin if ASrcIDList.Count > 0 then begin SavedQOperatOptions := AQOperat.Options; AQOperat.Options := AQOperat.Options - [qoAutoCommit, qoStartTransaction]; try SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, fnID+' = :'+fnID, nil, AUpdFieldName), false); AQOperat.Transaction.StartTransaction; AQOperat.Prepare; for i := 0 to ASrcIDList.Count - 1 do begin AQOperat.Close; AQOperat.Params[1].AsInteger := ASrcIDList[i]; AQOperat.Params[0].Value := ANewValue; AQOperat.ExecQuery; end; AQOperat.Transaction.Commit; finally AQOperat.Options := SavedQOperatOptions; end; end; end; procedure UpdateTableFieldStreamAllRec(AQOperat: TpFIBQuery; ATableName, AUpdFieldName: String; ANewValue: TStream); begin SetSQLToFIBQuery(AQOperat, GetSQLByParams(qtUpdate, ATableName, '', nil, AUpdFieldName), false); AQOperat.ParamByName(AUpdFieldName).LoadFromStream(ANewValue); AQOperat.ExecQuery; AQOperat.Close; end; function GetLastIDFromSQLMemTable(AMemTable: TSQLMemTable; const AIDFName: String): Integer; var SavedRecNo: Integer; FieldIndex: Integer; CurrID: Integer; begin Result := 0; try if Assigned(AMemTable) and AMemTable.Active then begin //AMemTable.Append; //AMemTable.Post; //Result := AMemTable.FieldByName(fnID).AsInteger; //AMemTable.Delete; FieldIndex := AMemTable.FieldDefs.IndexOf(AIDFName); if FieldIndex <> -1 then begin if AMemTable.RecordCount > 0 then // Tolik 27/12/2019 -- begin SavedRecNo := AMemTable.RecNo; AMemTable.First; while Not AMemTable.Eof do begin CurrID := AMemTable.Fields[FieldIndex].AsInteger; if Result < CurrID then Result := CurrID; AMemTable.Next; end; end; end; end; except on E: Exception do AddExceptionToLogEx('GetLastIDFromSQLMemTable', E.Message); end; end; procedure ExchangeDouble(var AValue1 , AValue2: Double); var Tmp: Double; begin tmp := AValue1; AValue1 := AValue2; AValue2 := tmp; end; procedure ExchangeIntegers(var AInt1, AInt2: Integer); var tmp: Integer; begin tmp := AInt1; AInt1 := AInt2; AInt2 := tmp; end; procedure ExchangeObjects(var AObj1, AObj2); var TmpObj: TObject; begin //if Assigned(TObject(AObj1)) and Assigned(TObject(AObj2)) then // if TObject(AObj1).ClassName = TObject(AObj2).ClassName then begin TmpObj := TObject(AObj1); TObject(AObj1) := TObject(AObj2); TObject(AObj2) := TObject(TmpObj); end; end; function CheckIsActiveKeyboardOrMouse: Boolean; var KeybState: TKeyboardState; KeyListToCheck: TIntList; i: Integer; begin Result := false; if GetKeyboardState(KeybState) then begin KeyListToCheck := TIntList.Create; KeyListToCheck.Add(VK_LBUTTON); KeyListToCheck.Add(VK_RBUTTON); KeyListToCheck.Add(VK_CANCEL); KeyListToCheck.Add(VK_MBUTTON); KeyListToCheck.Add(VK_BACK); KeyListToCheck.Add(VK_TAB); KeyListToCheck.Add(VK_CLEAR); KeyListToCheck.Add(VK_RETURN); KeyListToCheck.Add(VK_SHIFT); KeyListToCheck.Add(VK_CONTROL); KeyListToCheck.Add(VK_MENU); KeyListToCheck.Add(VK_PAUSE); KeyListToCheck.Add(VK_CAPITAL); KeyListToCheck.Add(VK_KANA); KeyListToCheck.Add(VK_HANGUL); KeyListToCheck.Add(VK_JUNJA); KeyListToCheck.Add(VK_FINAL); KeyListToCheck.Add(VK_HANJA); KeyListToCheck.Add(VK_KANJI); KeyListToCheck.Add(VK_CONVERT); KeyListToCheck.Add(VK_NONCONVERT); KeyListToCheck.Add(VK_ACCEPT); KeyListToCheck.Add(VK_MODECHANGE); KeyListToCheck.Add(VK_ESCAPE); KeyListToCheck.Add(VK_SPACE); KeyListToCheck.Add(VK_PRIOR); KeyListToCheck.Add(VK_NEXT); KeyListToCheck.Add(VK_END); KeyListToCheck.Add(VK_HOME); KeyListToCheck.Add(VK_LEFT); KeyListToCheck.Add(VK_UP); KeyListToCheck.Add(VK_RIGHT); KeyListToCheck.Add(VK_DOWN); KeyListToCheck.Add(VK_SELECT); KeyListToCheck.Add(VK_PRINT); KeyListToCheck.Add(VK_EXECUTE); KeyListToCheck.Add(VK_SNAPSHOT); KeyListToCheck.Add(VK_INSERT); KeyListToCheck.Add(VK_DELETE); KeyListToCheck.Add(VK_HELP); KeyListToCheck.Add(VK_LWIN); KeyListToCheck.Add(VK_RWIN); KeyListToCheck.Add(VK_APPS); KeyListToCheck.Add(VK_NUMPAD0); KeyListToCheck.Add(VK_NUMPAD1); KeyListToCheck.Add(VK_NUMPAD2); KeyListToCheck.Add(VK_NUMPAD3); KeyListToCheck.Add(VK_NUMPAD4); KeyListToCheck.Add(VK_NUMPAD5); KeyListToCheck.Add(VK_NUMPAD6); KeyListToCheck.Add(VK_NUMPAD7); KeyListToCheck.Add(VK_NUMPAD8); KeyListToCheck.Add(VK_NUMPAD9); KeyListToCheck.Add(VK_MULTIPLY); KeyListToCheck.Add(VK_ADD); KeyListToCheck.Add(VK_SEPARATOR); KeyListToCheck.Add(VK_SUBTRACT); KeyListToCheck.Add(VK_DECIMAL); KeyListToCheck.Add(VK_DIVIDE); KeyListToCheck.Add(VK_F1); KeyListToCheck.Add(VK_F2); KeyListToCheck.Add(VK_F3); KeyListToCheck.Add(VK_F4); KeyListToCheck.Add(VK_F5); KeyListToCheck.Add(VK_F6); KeyListToCheck.Add(VK_F7); KeyListToCheck.Add(VK_F8); KeyListToCheck.Add(VK_F9); KeyListToCheck.Add(VK_F10); KeyListToCheck.Add(VK_F11); KeyListToCheck.Add(VK_F12); KeyListToCheck.Add(VK_F13); KeyListToCheck.Add(VK_F14); KeyListToCheck.Add(VK_F15); KeyListToCheck.Add(VK_F16); KeyListToCheck.Add(VK_F17); KeyListToCheck.Add(VK_F18); KeyListToCheck.Add(VK_F19); KeyListToCheck.Add(VK_F20); KeyListToCheck.Add(VK_F21); KeyListToCheck.Add(VK_F22); KeyListToCheck.Add(VK_F23); KeyListToCheck.Add(VK_F24); KeyListToCheck.Add(VK_NUMLOCK); KeyListToCheck.Add(VK_SCROLL); KeyListToCheck.Add(VK_LSHIFT); KeyListToCheck.Add(VK_RSHIFT); KeyListToCheck.Add(VK_LCONTROL); KeyListToCheck.Add(VK_RCONTROL); KeyListToCheck.Add(VK_LMENU); KeyListToCheck.Add(VK_RMENU); KeyListToCheck.Add(VK_PROCESSKEY); KeyListToCheck.Add(VK_ATTN); KeyListToCheck.Add(VK_CRSEL); KeyListToCheck.Add(VK_EXSEL); KeyListToCheck.Add(VK_EREOF); KeyListToCheck.Add(VK_PLAY); KeyListToCheck.Add(VK_ZOOM); KeyListToCheck.Add(VK_NONAME); KeyListToCheck.Add(VK_PA1); KeyListToCheck.Add(VK_OEM_CLEAR); for i := 0 to KeyListToCheck.Count - 1 do begin if (KeybState[KeyListToCheck[i]] and 128) <> 0 then begin Result := true; Break; //// BREAK //// end; end; FreeAndNil(KeyListToCheck); end; end; function GetNBNow: TDateTime; begin Result := F_NormBase.DM.GetBaseNow; end; function GetPMNow: TDateTime; var CurrDate: TDate; CurrTime: TTime; begin with F_ProjMan.DM do begin Query_Select.Close; Query_Select.SQL.Text := 'select * from GET_NOW'; Query_Select.ExecQuery; CurrDate := Query_Select.FN('CURR_DATE').AsDate; CurrTime := Query_Select.FN('CURR_TIME').AsTime; Result := CurrDate + CurrTime; Query_Select.Close; end; end; procedure AutoSaveCurrentProject; var i: integer; begin with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then GSCSBase.CurrProject.CanAutoSave := true; {if Not GIsProgress then begin GSCSBase.CurrProject.StartStopAutoSaveProject(false); try StartCreepingNode(GSCSBase.CurrProject.TreeViewNode, 'сохранение'); try Application.OnMessage := F_Progress.Action; for i := 0 to 5 do begin sleep(300); Application.ProcessMessages; end; //*** Собственно сохранение GSCSBase.CurrProject.SaveProject; finally Application.OnMessage := nil; StopCreepingNode; end; //ShowMessage('End saving'); finally GSCSBase.CurrProject.StartStopAutoSaveProject(true); end; end;} end; function SaveDialogChecker(ASaveDialog: TSaveDialog): Boolean; var i: Integer; begin Result := true; for i := 0 to ASaveDialog.Files.Count - 1 do begin if FileExists(ASaveDialog.Files[i]) then begin Result := false; if MessageModal(cFileWithName+' "'+ExtractFileName(ASaveDialog.Files[i])+'" '+cNowExists+'. '+cQuastReplaceIt, ASaveDialog.Title, MB_ICONQUESTION or MB_YESNO) = IDYES then Result := true; if ASaveDialog.Files.Count > 0 then Break; ///// BREAK ///// end; end; end; procedure SaveProjectDateTime; begin with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin GSCSBase.CurrProject.StartStopAutoSaveDateTime(false); try GSCSBase.CurrProject.WriteUserNowDateTimeWithCheckName; finally GSCSBase.CurrProject.StartStopAutoSaveDateTime(true); end; end; end; // ########################### Связь с CAD-ом ################################## // ############################################################################# {<# // УСТАНОВКА НОВОГО ИМЕНИ ОБЬЕКТА В CAD-e Procedure SetNewObjectNameInCad(AID_Figure: Integer; AOldObjName, ANewObjName: String); begin exit; end; // УДАЛИТЬ ОБЬЕКТ ИЗ CAD (ПРИ УДАЛЕНИИ ЕГО ИЗ МП) Procedure DeleteObjectFromCad(AID_Figure: Integer; AObjName: String); begin Exit; end; // ОТКРЫТЫЙ ОБЬЕКТ В МП ВЫДЕЛИТЬ НА CAD-е Procedure SelectObjectInCAD(AID_Figure: Integer; AObjName: String); begin Exit; end; // Олегу для ТЕСТА (закоментировать!) // ПРИ СОЗДАНИИ ЛИСТА В МП СОЗДАТЬ ЕГО НА CAD-е Procedure AddListInCAD(ListID: Integer; ListName: String); begin Exit; end; // ПРИ ПЕРЕКЛЮЧЕНИИ ЛИСТА В МП ПЕРЕКЛЮЧИТЬ ЕГО НА CAD-е Procedure SwitchListInCAD(ListID: Integer; ListName: String); begin Exit; end; // ПРИ ПЕРЕИМЕНОВАНИИ ЛИСТА В МП ПЕРЕИМЕНОВАТЬ ЕГО НА CAD-е Procedure RenameListInCAD(ListID: Integer; OldListName, NewListName: String); begin Exit; end; // ПРИ УДАЛЕНИИ ЛИСТА В МП УДАЛИТЬ ЕГО НА CAD-е Procedure DeleteListInCAD(ListID: Integer; ListName: String); begin Exit; end; Procedure AppendLineInterfacesToCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TInterfLists); begin exit; end; Procedure AppendNoLineInterfacesToCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TList); begin exit; end; procedure RemoveLineInterfacesFromCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TInterfLists); begin exit; end; Procedure RemoveNoLineInterfacesFromCAD(AID_Figure: Integer; AObjName: string; AInterfaces: TList); begin Exit; end; // ##### Выделяет трассу на CAD-е ##### procedure SelectTraceInCAD(ATraceList: TList); begin Exit; end; // ##### Снимает выдиление трассы на CAD-е ##### procedure DeselectTraceInCAD; begin Exit; end; // ##### Получить интерфейсы сторон Объекта ##### function GetLineFigureInterfListsFromCAD(AIDFigure: Integer): TInterfLists; var IDCatalog: Integer; SCSCatalog: TSCSCatalog; begin try with F_ProjMan.DM do begin IDCatalog := GetIDCatalogByIDFigure(AIDFigure); SCSCatalog := TSCSCatalog.Create(TForm(F_ProjMan)); SCSCatalog.LoadCatalogByID(IDCatalog, true, false); Result := SCSCatalog.GetInterfIDLineObject; end; finally SCSCatalog.Free; end; end; procedure SetLineFigureCoordZInCAD(AID_Figure: Integer; ASide: Byte; ACoordZ: Double); begin // end; procedure SetConFigureCoordZInCAD(AID_Figure: Integer; ACoordZ: Double); begin // end; #>} function CreateSimpleRoomInPM(ACallFrom: TCallFrom; ASCSList: TObject; ARoomParams: TObjectParams; AReGroupObjects: Boolean): TObjectParams; var SCSList: TSCSList; NewListParams: TListParams; NewNode: TTreeNode; NewRoom: TSCSCatalog; begin Result := ARoomParams; SCSList := TSCSList(ASCSList); if SCSList.Setting.GroupListObjectsByType then begin NewListParams := SCSList.GetParams; NewListParams.Settings.GroupListObjectsByType := false; SaveListParams(SCSList.CurrID, NewListParams); end; NewNode := F_ProjMan.MakeDir(cfBase, SCSList.TreeViewNode, ARoomParams.Name, itRoom, @ARoomParams); if NewNode <> nil then begin F_ProjMan.Tree_Catalog.Selected := NewNode; NewRoom := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferences(PObjectData(NewNode.Data).ObjectID); if NewRoom <> nil then begin Result.ID := NewRoom.SCSID; if ACallFrom = cfBase then CreateCabinetOnCAD(NewRoom.SCSID, NewRoom.MarkID); end; end; end; function CreateRoomFromCADToPM(AListID: Integer): TObjectParams; var SCSList: TSCSList; RoomParams: TObjectParams; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if (SCSList <> nil) and (SCSList.TreeViewNode <> nil) then begin //ZeroMemory(@RoomParams, SizeOf(TObjectParams)); //RoomParams.MarkID := F_ProjMan.DM.GetCatalogMaxMarkID(itRoom, F_ProjMan.GSCSBase.CurrProject.CurrID, qmMemory); //Inc(RoomParams.MarkID); //RoomParams.Name := F_ProjMan.GSCSBase.CurrProject.Setting.DefRoomName; RoomParams := GetRoomParamsForNew(SCSList); Result := CreateSimpleRoomInPM(cfCAD, SCSList, RoomParams, true); end else ZeroMemory(@Result, SizeOf(TObjectParams)); end; procedure DeleteRoomFromCADToPM(ARoomID: Integer); begin DeleteObjectFromPM(ARoomID, ''); end; function GetRoomParamsForNew(ASCSList: TObject): TObjectParams; var SCSList: TSCSList; begin ZeroMemory(@Result, SizeOf(TObjectParams)); if (ASCSList <> nil) and (ASCSList is TSCSList) then begin SCSList := TSCSList(ASCSList); if (SCSList.TreeViewNode <> nil) then begin Result.MarkID := SCSList.GetMaxMarkIDFromChildReferences(itRoom); //F_ProjMan.DM.GetCatalogMaxMarkID(itRoom, F_ProjMan.GSCSBase.CurrProject.CurrID, qmMemory); Inc(Result.MarkID); Result.Name := SCSList.ProjectOwner.Setting.DefRoomName; Result.NameShort := DecToABC(Result.MarkID); end; end; end; procedure MoveObjectToRoomInPM(AListID, AObjectID, ANewRoomID: Integer); var SCSList: TSCSList; SCSObject: TSCSCatalog; NewRoom: TSCSCatalog; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin SCSObject := SCSList.GetCatalogFromReferencesBySCSID(AObjectID); if SCSObject <> nil then begin NewRoom := SCSList.GetCatalogFromReferencesBySCSID(ANewRoomID); if NewRoom <> nil then MoveSCSTreeObject(SCSObject, NewRoom) else MoveSCSTreeObject(SCSObject, TSCSCatalog(SCSList)); F_ProjMan.F_ChoiceConnectSide.DefineObjectParamsInFuture(SCSObject); end; end; end; // ДЛЯ ВОССОЗДАНИЯ В МЕНЕДЖЕРЕ ПРОЕКТОВ ОБЬЕКТА ТИПА ОРТОЛИНИЯ/КОНЕКТОР Function SendObjectToPrjManager(ID_Figure, ID_CAD, AIDRoom: Integer; const ObjName: String; ASCSObjectKind: TSCSObjectKind): TTreeNode; var ItemType: TItemType; //CurrNode: TTreeNode; TargetNode: TTreeNode; NewObj: TTreeNode; IDCatalog: Integer; NewIndex: Integer; //LineGroupNode: TTreeNode; //ConnGroupNode: TTreeNode; SCSList: TSCSList; SCSRoom: TSCSCatalog; SCSObject: TSCSCatalog; begin //Exit; //#Del Result := nil; //Result := -1; try ItemType := -1; SCSList := nil; SCSRoom := nil; TargetNode := nil; IDCatalog := 0; // обьект - ортолиния (линейный) if ASCSObjectKind = okLine then ItemType := itSCSLine; // обьект - конектор (точечный) if (ASCSObjectKind = okPointObject) or (ASCSObjectKind = okConnector) then ItemType := itSCSConnector; with F_ProjMan do begin //*** Проверка на соответствие типов //Tolik 09/11/2021 -- //SCSList := GSCSBase.CurrProject.GetListBySCSID(ID_CAD); SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(ID_CAD); // if Not Assigned(SCSList) then Exit; ///// EXIT ///// if AIDRoom > 0 then SCSRoom := SCSList.GetCatalogFromReferencesBySCSID(AIDRoom); if SCSRoom <> nil then begin if SCSRoom.TreeViewNode = nil then FindComponOrDirInTree(scsRoom.ID, false); if SCSRoom.TreeViewNode <> nil then begin TargetNode := SCSRoom.TreeViewNode; IDCatalog := SCSRoom.ID; end; end; if TargetNode = nil then begin TargetNode := SCSList.TreeViewNode; IDCatalog := SCSList.ID; end; //IDCatalog := DM.GetIDCatalogByIDList(ID_CAD); //if IDCatalog <> 0 then begin //LineGroupNode := nil; //ConnGroupNode := nil; if Not Assigned(TargetNode) then //Tolik 09/11/2021 - - //TargetNode := FindComponOrDirInTree(IDCatalog, false); TargetNode := F_ProjMan.FindComponOrDirInTree(IDCatalog, false); // //FindGroupNodes(ListNode, LineGroupNode, ConnGroupNode); if TargetNode = nil then begin ShowMessage(cBaseCommon47); Exit; end; //Tree_Catalog.Items.BeginUpdate; //CurrNode := Tree_Catalog.Selected; //Tolik 09/11/2021 -- //NewObj := MakeDir(cfCAD, TargetNode, ObjName, ItemType, nil, ID_Figure); NewObj := F_ProjMan.MakeDir(cfCAD, TargetNode, ObjName, ItemType, nil, ID_Figure); // {if (ItemType = itSCSLine) and (LineGroupNode <> nil) then NewObj.MoveTo(LineGroupNode, naAddChild); if (ItemType = itSCSConnector) and (ConnGroupNode <> nil) then NewObj.MoveTo(ConnGroupNode, naAddChild);} //SCSObject := TSCSCatalog.Create(TForm(F_ProjMan)); //SCSObject.LoadCatalogByID(PObjectData(NewObj.Data).ObjectID, false); SCSObject := nil; //Tolik 09/11/2021-- //SCSObject := GSCSBase.CurrProject.GetCatalogFromReferences(PObjectData(NewObj.Data).ObjectID); SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferences(PObjectData(NewObj.Data).ObjectID); // if SCSObject = nil then Exit; ///// EXIT ///// //*** Если объект должен попасть в комнату и не попал то закинуть его туда if (SCSRoom <> nil) and (SCSObject.Parent is TSCSList) then MoveSCSTreeObject(SCSObject, SCSRoom); NewIndex := GenObjectNewIndex(SCSObject, ASCSObjectKind); SetIndexToFigure(ID_CAD, ID_Figure, NewIndex); //*** На КАД case ASCSObjectKind of okConnector: SCSObject.IndexConnector := NewIndex; okPointObject: SCSObject.IndexPointObj := NewIndex; okLine: SCSObject.IndexLine := NewIndex; end; //Tolik 09/11/2021 -- //SCSObject.NameMark := MakeNameMarkCatalog(PObjectData(NewObj.Data).ObjectID, true, qmMemory); SCSObject.NameMark := F_ProjMan.MakeNameMarkCatalog(PObjectData(NewObj.Data).ObjectID, true, qmMemory); //NewObj.Text := GetObjNameForVisible(SCSObject, ppPM); NewObj.Text := F_ProjMan.GetObjNameForVisible(SCSObject, ppPM); // //SCSObject.Free; {if GIsObjectIndexing then begin NewObj.Text := GetNameWithIndex(NewObj.Text, NewIndex); //SetNewObjectNameInCad(ID_Figure, ObjName, GetNameWithIndex(ObjName, NewIndex)); end;} Result := NewObj; //Tree_Catalog.Selected := CurrNode; //Tree_Catalog.Items.EndUpdate end; end; except on E: Exception do AddExceptionToLog('SendObjectToPrjManager: '+E.Message); end; end; // ДЛЯ КОПИРОВАНИЯ КОМПОНЕНТЫ В ОБЬЕКТ МЕНЕДЖЕРА ПРОЕКТОВ function CopyComponentToPrjManager(ListNode: TTreeNode; ID_Figure, ID_CAD{, AIDCopyCompon}: Integer; AComponToCopy: TObject; ACreateObjectOnClick: Boolean; AFromHuman: Boolean = false): Integer; var ID_CopyCompon: Integer; CurrNode: TTreeNode; SCSList: TSCSList; NewComponID: Integer; NewSCCompon: TSCSComponent; // Tolik 28/08/2019 -- //OldTick: Cardinal; //CurrTick: Cardinal; OldTick, CurrTick: DWord; // GuidStr: String; GProp: PProperty; begin //Exit; //#Del Result := 0; try OldTick := GetTickCount; if (AComponToCopy <> nil) and (AComponToCopy is TSCSComponent) then begin //Tolik 17/02/2022 -- здесь подкинем шкаф из базы, если кидается шкаф из шаблонов //(так сказать, замена на ходу) -- РоМА сказал так сделать //ID_CopyCompon := TSCSComponent(AComponToCopy).ID; if TSCSComponent(aComponToCopy).isTemplate = biFalse then ID_CopyCompon := TSCSComponent(AComponToCopy).ID else //if Assigned(TSCSComponent(AComponToCopy).ComponentType) then begin GuidStr := ''; GProp := TSCSComponent(AComponToCopy).GetPropertyBySysName(pnGUID_NB_EXCHANGE); if GProp <> nil then begin if GProp.Value <> '' then GuidStr := GProp.Value; end; if GuidStr = '' then begin if TSCSComponent(AComponToCopy).ComponentType.SysName <> 'CUPBOARD' then ID_CopyCompon := TSCSComponent(AComponToCopy).ID else begin if TSCSComponent(AComponToCopy).GuidNB = '{B0616CAB-B556-4974-AA34-6DFD02B2BE0E}' then GuidStr := '{D72026D8-BD09-4063-8949-834453C4079E}' else if TSCSComponent(AComponToCopy).GuidNB = '{643657CB-3C82-4EBD-B24D-1E42FAC74345}' then GuidStr := '{D39721B7-FC72-4D2F-ACD4-7171B7A9FB3C}'; if GuidStr <> '' then begin ID_CopyCompon := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, GuidStr, qmPhisical); if ID_CopyCompon = -1 then ID_CopyCompon := TSCSComponent(AComponToCopy).ID; end else ID_CopyCompon := TSCSComponent(AComponToCopy).ID; end; end else begin ID_CopyCompon := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, GuidStr, qmPhisical); if ID_CopyCompon = -1 then ID_CopyCompon := TSCSComponent(AComponToCopy).ID; end; end; // with F_ProjMan do begin if ListNode <> Nil then begin CurrNode := Tree_Catalog.Selected; NewComponID := CopyComponentFromNbToPm(F_NormBase, FProjectMan, TSCSComponent(AComponToCopy).TreeViewNode, ListNode, ID_CopyCompon, ckCompon, AFromHuman); //Tree_Catalog.Selected := CurrNode; Result := NewComponID; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(ID_CAD); if SCSList <> nil then begin if Not ACreateObjectOnClick or (SCSList.FCreatedObjCountOnClick = 0) then begin NewSCCompon := SCSList.GetComponentFromReferences(NewComponID); if NewSCCompon <> nil then F_NormBase.DM.AddComponGUIDToFreqUseObj(NewSCCompon.GuidNB); end; if ACreateObjectOnClick then Inc(SCSList.FCreatedObjCountOnClick); end; end; end; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; except on E: Exception do AddExceptionToLog('CopyComponentToPrjManager: '+E.Message); end; end; /// ДЛЯ КОПИРОВАНИЯ КОМПОНЕНТЫ В ОБЬЕКТ МЕНЕДЖЕРА ПРОЕКТОВ function CopyComponentToSCSObject(AID_Figure,AIDCopyCompon: integer; AFromHuman: Boolean = false; AOutSCSObj: Pointer=nil): Integer; var //ID_Obj: Integer; ObjNode: TTreeNode; ObjDat: PObjectData; IsLine: Boolean; SCSObject: TSCSCatalog; //Compon: TSCSComponent; IsAciveFormProgress: Boolean; // Tolik 28/08/2019 - - //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // SCSList: TSCSList; NewSCCompon: TSCSComponent; //Tolik 20/04/2022 -- GuidStr: String; GProp: PProperty; ID_CopyCompon: integer; begin //Exit; //#Del Result := -1; SCSObject := nil; ObjNode := nil; OldTick := getTickCount; try with F_ProjMan do begin IsAciveFormProgress := false; if AFromHuman then IsAciveFormProgress := GetIsActiveFormProgress; if IsAciveFormProgress then PauseProgress(true); try SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AID_Figure); if AOutSCSObj <> nil then TSCSCatalog(AOutSCSObj^) := SCSObject; if SCSObject <> nil then begin if Assigned(SCSObject) then ObjNode := SCSObject.TreeViewNode; if Not Assigned(ObjNode) then ObjNode := FindComponOrDirInTree(SCSObject.ID, false); if ObjNode <> nil then begin //*** компонент с НБ //Compon := TSCSComponent.Create(TForm(F_NormBase)); //Compon.LoadComponentByID(AIDCopyCompon, false); IsLine := False; if F_NormBase.GSCSBase.SCSComponent.ID = AIDCopyCompon then //Tolik 20/04/2022-- // IsLine := IntToBool(F_NormBase.GSCSBase.SCSComponent.IsLine) begin IsLine := IntToBool(F_NormBase.GSCSBase.SCSComponent.IsLine); if isLine then begin GuidStr := ''; F_NormBase.GSCSBase.SCSComponent.LoadProperties; GProp := F_NormBase.GSCSBase.SCSComponent.GetPropertyBySysName(pnGUID_NB_EXCHANGE); if GProp <> nil then begin if GProp.Value <> '' then GuidStr := GProp.Value; end; if GuidStr <> '' then begin ID_CopyCompon := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, GuidStr, qmPhisical); if ID_CopyCompon <> -1 then AIDCopyCompon := ID_CopyCompon; end; end; end // else IsLine := isLineCompon(TForm(F_NormBase), AIDCopyCompon); //*** Целевой объект в МП ObjDat := ObjNode.Data; //if ((ObjDat.ItemType = itSCSLine) and (Compon.IsLine = biTrue)) or // ((ObjDat.ItemType = itSCSConnector) and (Compon.IsLine = biFalse)) then // Result := CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ObjNode, AIDCopyCompon, ckCompon); if ((ObjDat.ItemType = itSCSLine) and (IsLine = True)) or ((ObjDat.ItemType = itSCSConnector) and (IsLine = False)) then begin Result := CopyComponentFromNbToPm(F_NormBase, F_ProjMan, nil, ObjNode, AIDCopyCompon, ckCompon, AFromHuman); SCSList := SCSObject.GetListOwner; if SCSList <> nil then begin if AFromHuman then begin NewSCCompon := SCSList.GetComponentFromReferences(Result); if NewSCCompon <> nil then F_NormBase.DM.AddComponGUIDToFreqUseObj(NewSCCompon.GuidNB); end; end; end; //if Compon.IsLine = biTrue then // AutoConnectOnAppendCable(AID_Figure); //Compon.Free; end; end; finally if IsAciveFormProgress then PauseProgress(false); end; end; except on E: Exception do AddExceptionToLog('CopyComponentToSCSObject: '+E.Message); end; CurrTick := GetTickCount - oldTick; CurrTick := GetTickCount - oldTick; end; // ##### Копирует компоненты с одного оюъекта в другой ##### procedure DublicateObjectComponents(AIDSrcFigure, AIDTrgFigure: Integer); var SrcObject: TSCSCatalog; TrgObject: TSCSCatalog; TrgNode: TTreeNode; i, j: Integer; SrcComponent: TSCSComponent; JoinedToSrcComponent: TSCSComponent; IDNewComponent: Integer; //NewComponent: TSCSComponent; //JoinedToNewComponent: TSCSComponent; //InternalObjectComponent: TSCSComponents; //InternalObjectJoined: TSCSComponents; begin //Exit; //#Del try with F_ProjMan do begin if Not GIsDublicatingCADObjects then begin SrcObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDSrcFigure); TrgObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDTrgFigure); if Assigned(SrcObject) and Assigned(TrgObject) then begin TrgNode := TrgObject.TreeViewNode; if TrgNode = nil then TrgNode := FindComponOrDirInTree(TrgObject.ID, false); if TrgNode <> nil then begin //InternalObjectComponent := TSCSComponents.Create(false); //InternalObjectJoined := TSCSComponents.Create(false); for i := 0 to SrcObject.SCSComponents.Count - 1 do begin SrcComponent := SrcObject.SCSComponents[i]; //*** Найти поключенные компоненты внутри объекта //if InternalObjectJoined.IndexOf(SrcComponent) = -1 then // for j := 0 to SrcComponent.JoinedComponents.Count - 1 do // begin // JoinedToSrcComponent := SrcComponent.JoinedComponents[j]; // //*** Компоненты внутри объекта, но не внутри одной компоненты // if (JoinedToSrcComponent.GetFirstParentCatalog = SrcObject) and // (SrcComponent.GetTopComponent <> JoinedToSrcComponent.GetTopComponent) then // begin // InternalObjectComponent.Add(SrcComponent); // InternalObjectJoined.Add(JoinedToSrcComponent); // end; // end; IDNewComponent := CopyComponentFromNbToPm(TForm(F_ProjMan), TForm(F_ProjMan), nil, TrgNode, SrcComponent.ID, ckCompon); //NewComponent := GSCSBase.CurrProject.GetComponentFromReferences(IDNewComponent); //if NewComponent <> nil then //begin // NewComponent.Interfaces.Clear; //end; end; //*** Подключить компоненты внутри объекта (не компоненты) //if (InternalObjectComponent.Count > 0) and // (InternalObjectComponent.Count = InternalObjectJoined.Count) then // for i := 0 to InternalObjectComponent.Count - 1 do // begin // SrcComponent := InternalObjectComponent[i]; // JoinedToSrcComponent := InternalObjectJoined[i]; // // NewComponent := nil; // JoinedToNewComponent := nil; // NewComponent := GetComponentByOldIDFromObject(TrgObject, SrcComponent.ID); // if NewComponent <> nil then // JoinedToNewComponent := GetComponentByOldIDFromObject(TrgObject, JoinedToSrcComponent.ID); // if (NewComponent <> nil) and (JoinedToNewComponent <> nil) then // NewComponent.JoinTo(JoinedToNewComponent, -1, -1); // end; //FreeAndNil(InternalObjectComponent); //FreeAndNil(InternalObjectJoined); end; end; end else if GIsDublicatingCADObjects then begin GSCSBase.CurrProject.IDsSrcObjects.Add(AIDSrcFigure); GSCSBase.CurrProject.IDsNewObjects.Add(AIDTrgFigure); end; end; {with F_ProjMan do begin SrcObject := nil; TrgNode := nil; IDTrgCat := DM.GetIDCatalogByIDFigure(AIDTrgFigure); TrgNode := FindComponOrDirInTree(IDTrgCat, false); if TrgNode <> nil then begin SrcObject := TSCSCatalog.Create(TForm(F_ProjMan)); try SrcObject.LoadCatalogByIDFigure(AIDSrcFigure, true, false); for i := 0 to SrcObject.SCSComponents.Count - 1 do begin SrcComponent := SrcObject.SCSComponents[i]; CopyComponentFromNbToPm(TForm(F_ProjMan), TForm(F_ProjMan), TrgNode, SrcComponent.ID, ckCompon); end; finally FreeAndNil(SrcObject); end; end; end; } except on E: Exception do AddExceptionToLog('DublicateObjectComponents: '+E.Message); end; end; function ComplectNBComponToProjObj(AFigureID: Integer; ANBCompon: TObject; AOnlyCheck: Boolean): Boolean; var SCSObj: TSCSCatalog; FirstCompon: TSCSComponent; begin Result := false; try SCSObj := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AFigureID); if SCSObj <> nil then begin FirstCompon := SCSObj.GetFirstComponent; if FirstCompon <> nil then Result := ComplectNBComponToProjCompon(FirstCompon.ID, ANBCompon, AOnlyCheck); end; except on E: Exception do AddExceptionToLogEx('ComplectNBComponToProjObj', E.Message); end; end; function ComplectNBComponToProjCompon(AIDProjCompon: Integer; ANBCompon: TObject; AOnlyCheck: Boolean): Boolean; var ProjCompon: TSCSComponent; NBComponent: TSCSComponent; Timer_DefineObjetsParamsInCAD: TTimer; begin Result := false; try if (ANBCompon <> nil) and (ANBCompon is TSCSComponent) then begin ProjCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDProjCompon); if ProjCompon <> nil then begin NBComponent := TSCSComponent.Create(F_NormBase); try NBComponent.LoadComponentByID(TSCSComponent(ANBCompon).ID); if AOnlyCheck then begin Result := ProjCompon.CheckComplectWith(NBComponent).CanConnect; if Not Result then if (ProjCompon.ComponentType.SysName = ctsnCupBoard) and NBComponent.IsCrossComponent then Result := true; end else begin if ProjCompon.TreeViewNode = nil then ProjCompon.TreeViewNode := F_ProjMan.FindComponOrDirInTree(AIDProjCompon, true); if ProjCompon.TreeViewNode <> nil then begin Result := F_ProjMan.AddComplect(F_NormBase, TSCSComponent(ANBCompon).TreeViewNode, ProjCompon.TreeViewNode, TSCSComponent(ANBCompon), cntComplect, 1, false); Timer_DefineObjetsParamsInCAD := F_ProjMan.F_ChoiceConnectSide.Timer_DefineObjetsParamsInCAD; if Timer_DefineObjetsParamsInCAD.Enabled then if Assigned(Timer_DefineObjetsParamsInCAD.OnTimer) then Timer_DefineObjetsParamsInCAD.OnTimer(Timer_DefineObjetsParamsInCAD); //F_ProjMan.F_ChoiceConnectSide.Timer_DefineObjetsParamsInCADTimer(Timer_DefineObjetsParamsInCAD); end; end; finally FreeAndNil(NBComponent); end; end; end; except on E: Exception do AddExceptionToLogEx('ComplectNBComponToProjCompon', E.Message); end; end; // УСТАНОВКА НОВОГО ИМЕНИ ОБЬЕКТА В МП Procedure SetNewObjectNameInPM(ID_Figure: Integer; ObjName: String); var ID_Obj: Integer; ObjNode: TTreeNode; SCSObject: TSCSCatalog; begin try if ObjName <> '' then with F_ProjMan do begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(ID_Figure); if Assigned(SCSObject) then begin ObjNode := SCSObject.TreeViewNode; if Not Assigned(ObjNode) then ObjNode := FindComponOrDirInTree(SCSObject.ID, false); if ObjNode <> nil then if SCSObject.ItemType in [itSCSLine, itSCSConnector] then ObjNode.Text := RenameNode(cfCad, ObjNode, SCSObject, ObjName); end; { ID_Obj := DM.GetIDCatalogByIDFigure(ID_Figure); ObjNode := nil; ObjNode := FindComponOrDirInTree(ID_Obj, false); if ObjNode <> nil then if PObjectData(ObjNode.Data).ItemType in [itSCSLine, itSCSConnector] then ObjNode.Text := RenameNode(cfCad, ObjNode, ObjName); } end; except on E: Exception do AddExceptionToLog('SetNewObjectNameInPM: '+E.Message); end; end; Procedure SetNewListNameInPM(AIDList: Integer; ANewName: String); var ListNode: TTreeNode; List: TSCSList; begin try List := nil; with F_ProjMan do begin List := GSCSBase.CurrProject.GetListBySCSID(AIDList); if List <> nil then begin ListNode := nil; ListNode := FindComponOrDirInTree(List.ID, false); if ListNode <> nil then begin ListNode.Text := RenameNode(cfCad, ListNode, List, ANewName); ListNode.Text := GetNameNode(ListNode, List, true, true); end; end; end; except on E: Exception do AddExceptionToLog('SetNewListNameInPM: '+E.Message); end; end; function GetListNameFromPM(AIDList: Integer): String; var List: TSCSList; begin Result := ''; with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin List := GSCSBase.CurrProject.GetListBySCSID(AIDList); if Assigned(List) then Result := List.Name; end; end; Procedure AddConnObjectInPM(ID_Figure, AIDRoom: Integer; ObjName: String); var CurrListNode: TTreeNode; SCSList: TSCSList; begin // Tolik 25/07/2017 -- if ID_Figure = 0 then AddExceptionToLog('AddConnObjectInPM: Attention! ID_Figure = 0!!!'); // try SCSList := nil; CurrListNode := nil; with F_ProjMan do begin //IDCatalog := DM.GetIDCatalogByIDList(GIDLastList); if Assigned(GSCSBase.CurrProject) then if Assigned(GSCSBase.CurrProject.CurrList) then begin CurrListNode := GSCSBase.CurrProject.CurrList.TreeViewNode; SendObjectToPrjManager(ID_Figure, GSCSBase.CurrProject.CurrList.CurrID, AIDRoom, ObjName, okConnector); {if Not Assigned(CurrListNode) then CurrListNode := FindComponOrDirInTree(GSCSBase.CurrProject.CurrList.ID, false); if Assigned(CurrListNode) then MakeDir(cfCAD, CurrListNode, ObjName, itSCSConnector, ID_Figure);} end; { if IDCatalog <> 0 then begin CurrListNode := FindComponOrDirInTree(IDCatalog, false); if CurrListNode <> nil then MakeDir(cfCAD, CurrListNode, ObjName, itSCSConnector, ID_Figure); end; } end; except on E: Exception do AddExceptionToLog('AddConnObjectInPM: '+E.Message); end; end; function CanDelSCSObject(AObject: TObject): Boolean; begin Result := false; if AObject is TSCSCatalog then if (TSCSCatalog(AObject).ItemType in [itSCSLine, itSCSConnector]) and CanDeleteObjectFromPM(TSCSCatalog(AObject).ListID, TSCSCatalog(AObject).SCSID) and Not IsLockedObject(TSCSCatalog(AObject).ListID, TSCSCatalog(AObject).SCSID) then begin Result := true; end; end; function BeforeDelObjectFromPM(ACallFrom: TCallFrom; AListID, AFigure: Integer; {ASaveToUnoStack: Booelan;} ARelatedLists: TIntList=nil): Boolean; var ObjectIDsToDel: TIntList; ComponentList: TSCSComponents; SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; JoinedComponent: TSCSComponent; i, j, k: Integer; SameJoinedCount: Integer; DelComponMode: TDelComponMode; CanDelOnWholeLen: Boolean; begin Result := true; ObjectIDsToDel := nil; try if ACallFrom = cfBase then ObjectIDsToDel := TIntList.Create else if ACallFrom = cfCAD then ObjectIDsToDel := GetObjectsListWithSelectedInCAD(AListID); if ObjectIDsToDel <> nil then begin if ObjectIDsToDel.IndexOf(AFigure) = -1 then ObjectIDsToDel.Add(AFigure); ComponentList := TSCSComponents.Create(false); // Отобрать линейные компоненты SameJoinedCount := 0; for i := 0 to ObjectIDsToDel.Count - 1 do begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ObjectIDsToDel[i]); if SCSCatalog <> nil then for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin SCSComponent := SCSCatalog.ComponentReferences[j]; if SCSComponent.IsLine = biTrue then begin ComponentList.Add(SCSComponent); SCSComponent.ServToDelete := true; for k := 0 to SCSComponent.JoinedComponents.Count - 1 do begin JoinedComponent := SCSComponent.JoinedComponents[k]; if JoinedComponent.GuidNB = SCSComponent.GuidNB then Inc(SameJoinedCount); end; end; end; end; if (ComponentList.Count > 0) and (SameJoinedCount > 0) then begin CanDelOnWholeLen := true; // Если еть подключенные линейные компоненты, то спросить удалять по всей длине, илил же на выбранных участках DelComponMode := dmNone; if F_ProjMan.FMultipleAction then DelComponMode := F_ProjMan.FMultipleDelComponMode; if DelComponMode = dmNone then begin PauseProgressByMode(true); try DelComponMode := F_ProjMan.F_InputBox.ChoiceDelComponMode('', true); finally PauseProgressByMode(false); end; if F_ProjMan.FMultipleAction then F_ProjMan.FMultipleDelComponMode := DelComponMode; end; if DelComponMode <> dmNone then begin if DelComponMode = dmArea then CanDelOnWholeLen := false; F_ProjMan.DelComponentsFromList(F_ProjMan.GSCSBase.CurrProject.CurrList, ComponentList, CanDelOnWholeLen, biNone, (ARelatedLists<>nil), ARelatedLists); end else Result := false; end; //16.02.2012 else //16.02.2012 if ARelatedLists <> nil then //16.02.2012 SaveListsToUndoStack(ARelatedLists); FreeAndNil(ComponentList); end; except on E: Exception do AddExceptionToLogEx('BeforeDelObjectFromPM', E.Message); end; // Tolik 15/05/2018 -- if ObjectIDsToDel <> nil then ObjectIDsToDel.Free; // end; // УДАЛИТЬ ОБЬЕКТ ИЗ МП (ПРИ УДАЛЕНИИ ЕГО НА CAD) Procedure DeleteObjectFromPM(ID_Figure: Integer; const ObjName: String; aIsManual: Boolean=false); var SCS_ID: Integer; DelComponName: String; ID_Obj: Integer; Node: TTreeNode; ItemType: Integer; SCSCatalog: TSCSCatalog; ParentObject: TBasicSCSClass; //i: Integer; //Compons: TSCSComponents; //Compon: TSCSComponent; //DlCatalog: Procedure(ACallFrom: TCallFrom; AIDCatalog, AIDItemType: Integer); begin //Exit; //#Del try SCS_ID := ID_Figure; Node := nil; DelComponName := ObjName; with F_ProjMan do if Assigned(F_ProjMan.DM.OnDelCADObject) then begin SCSCatalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(ID_Figure); if Assigned(SCSCatalog) then begin // //if (CompTypeSysName = ctsnHouse) or (CompTypeSysName = ctsnApproach) then //begin //ListID := GCadForm.FCADListID; //AComponent.ListID := ListID; //if Catalog <> nil then // Catalog.ListID := ListID; //if ObjectOwner <> nil then //begin // ObjectOwner.SCSID := ObjectOwner.SCSID; //end; // исправление не помогает - все одно с ПМ-ки не с того листа удаляет - нужно рихтовки после открытия проекта делать //if CatalogToDel <> GCadForm.FCADListID then //begin {$IF Defined(SCS_PE)} //ShowMessage('Unable to remove it'); {$ELSE} // ShowMessage('Невозможно удалить данный объект'); {$IFEND} // exit; // end; //end; begin if (SCSCatalog.ListID <> GCadForm.FCADListID) then begin {$IF Defined(BASEADM_SCS)} if aIsManual then ShowMessage('Невозможно удалить данный компонент'); {$IFEND} exit; end; end; Node := SCSCatalog.TreeViewNode; if Not Assigned(Node) then Node := FindComponOrDirInTree(SCSCatalog.ID, false); if Assigned(Node) then if Not(SCSCatalog.ItemType in [itProjMan, itProject, itList]) then if Not SCSCatalog.ServDeleting then begin //24.07.2013 Удалить компонент по всей длине {if SCSCatalog.ItemType = itSCSLine then if SCSCatalog.SCSComponents.Count > 0 then begin Compons := TSCSComponents.Create(false); for i := 0 to SCSCatalog.SCSComponents.Count - 1 do begin Compons.Clear; Compons.Add(SCSCatalog.SCSComponents[i]); DelComponentsFromList(SCSCatalog.GetListOwner, Compons, true, biTrue, false); end; FreeAndNil(Compons); end;} //OnAddDeleteNode(Node, SCSCatalog, false); //DeleteNode(Node); SCSCatalog.TreeViewNode := nil; SCSCatalog.ServDeleting := true; SCSCatalog.ServDeleteInCAD := true; ParentObject := SCSCatalog.Parent; try DM.OnDelCADObject(cfCAD, SCSCatalog.ID, SCSCatalog.ItemType, SCSCatalog.QueryMode, SCSCatalog, aIsManual); finally OnAddDeleteNode(Node, nil, ParentObject, false); DeleteNode(Node); end; //RefreshNode(true); end; end; { SCS_ID := DM.GetCatalogFieldValueAsInteger(SCS_ID, fnSCSID, fnSCSID, qmMemory); if SCS_ID > 0 then begin ID_Obj := DM.GetIDCatalogByIDFigure(SCS_ID); Node := nil; Node := FindComponOrDirInTree(ID_Obj, false); if Node <> nil then begin ItemType := PObjectData(Node.Data).ItemType; if PObjectData(Node.Data).ObjectID = ID_Obj then if Not(ItemType in [itProjMan, itProject, itList]) then begin DeleteNode(Node); DM.DelCatalog(cfCAD, ID_Obj, ItemType); end; end; //DM.DelDir(ID_Obj); end; } end; except on E: Exception do AddExceptionToLog('DeleteObjectFromPM: '+E.Message); end; end; procedure SetObjectToDeleteInPM(AIDFIgure: Integer); var SCSCatalog: TSCSCatalog; begin try SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFIgure); if SCSCatalog <> nil then SCSCatalog.ServDeleteInCAD := true; except on E: Exception do AddExceptionToLogEx('SetObjectToDeleteInPM', E.Message); end; end; Function GetTreeNodeByID(AID_Figure: Integer): TTreeNode; var Catalog: TSCSCatalog; begin try with F_ProjMan do begin Catalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AID_Figure); if Assigned(Catalog) then begin Result := nil; if Catalog.SCSComponents.Count > 0 then begin Result := Catalog.SCSComponents.Items[0].TreeViewNode; if Not Assigned(Result) then result := FindComponOrDirInTree(TSCSComponent(Catalog.SCSComponents.Items[0]).ID, true) end else result := Catalog.TreeViewNode; //FindComponOrDirInTree(ObjID, false); if Not Assigned(Result) then result := FindComponOrDirInTree(Catalog.ID, false); end; end; except on E: Exception do AddExceptionToLog('GetTreeNodeByID: '+E.Message); end; end; // ВЫДЕЛЕННЫЙ ОБЬЕКТ НА CAD-е РАЗВЕРНУТЬ В МП Procedure ShowObjectInPM(AID_Figure: Integer; AObjName: String; aShowNode: Boolean = True); var Node: TTreeNode; FirstChildNode: TTreeNode; ObjID: Integer; Catalog: TSCSCatalog; //LastRoom: TSCSCatalog; begin //Exit; //#Del try with F_ProjMan do begin Catalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AID_Figure); if Assigned(Catalog) then begin Node := nil; FirstChildNode := nil; if Catalog.SCSComponents.Count > 0 then begin Node := Catalog.SCSComponents.Items[0].TreeViewNode; if Not Assigned(Node) then Node := FindComponOrDirInTree(TSCSComponent(Catalog.SCSComponents.Items[0]).ID, true) end else Node := Catalog.TreeViewNode; //FindComponOrDirInTree(ObjID, false); if Not Assigned(Node) then Node := FindComponOrDirInTree(Catalog.ID, false); //Tolik if aShowNode then begin // if Assigned(Node) then begin Tree_Catalog.Items.BeginUpdate; try Tree_Catalog.Selected := Node; if Tree_Catalog.Selected <> Node then Tree_Catalog.Selected := Node; //Tolik if aShowNode then ShowSelectedNode(Tree_Catalog); finally Tree_Catalog.Items.EndUpdate; end; {//*** Деактивация кабинета на КАДе после Change в Tree_Catalog if (FLastNodeDat.ObjectID > 0) and (FLastNodeDat.ItemType = itRoom) then begin LastRoom := GSCSBase.CurrProject.GetCatalogFromReferences(FLastNodeDat.ObjectID); if LastRoom <> nil then DeactivateCabinetOnCAD(LastRoom.SCSID); end;} end; end; end; (* ObjID := DM.GetIDCatalogByIDFigure(AID_Figure); Catalog := TSCSCatalog.Create(TForm(F_ProjMan)); Catalog.LoadCatalogByID(ObjID, true, false); Node := nil; FirstChildNode := nil; if Catalog.SCSComponents.Count > 0 then Node := FindComponOrDirInTree(TSCSComponent(Catalog.SCSComponents.Items[0]).ID, true) else Node := FindComponOrDirInTree(ObjID, false); if Node <> nil then begin Tree_Catalog.Selected := Node; {FirstChildNode := Node.GetFirstChild; if FirstChildNode <> nil then Tree_Catalog.Selected := FirstChildNode else Tree_Catalog.Selected := Node;} end; Catalog.Free; *) end; except on E: Exception do AddExceptionToLog('ShowObjectInPM: '+E.Message); end; end; // Tolik // РАЗВЕРНУТЬ КАТАЛОГ В МП Procedure ShowCatalogInPM(ACatalog : TSCSCatalog; aShowNode: Boolean = True); var Node: TTreeNode; FirstChildNode: TTreeNode; ObjID: Integer; Catalog: TSCSCatalog; //LastRoom: TSCSCatalog; begin //Exit; //#Del try with F_ProjMan do begin Catalog := ACatalog; if Assigned(Catalog) then begin Node := nil; FirstChildNode := nil; if Catalog.SCSComponents.Count > 0 then begin Node := Catalog.SCSComponents.Items[0].TreeViewNode; if Not Assigned(Node) then Node := FindComponOrDirInTree(TSCSComponent(Catalog.SCSComponents.Items[0]).ID, true) end else Node := Catalog.TreeViewNode; //FindComponOrDirInTree(ObjID, false); if Not Assigned(Node) then Node := FindComponOrDirInTree(Catalog.ID, false); //Tolik if aShowNode then begin // if Assigned(Node) then begin Tree_Catalog.Items.BeginUpdate; try Tree_Catalog.Selected := Node; if Tree_Catalog.Selected <> Node then Tree_Catalog.Selected := Node; //Tolik if aShowNode then ShowSelectedNode(Tree_Catalog); finally Tree_Catalog.Items.EndUpdate; end; {//*** Деактивация кабинета на КАДе после Change в Tree_Catalog if (FLastNodeDat.ObjectID > 0) and (FLastNodeDat.ItemType = itRoom) then begin LastRoom := GSCSBase.CurrProject.GetCatalogFromReferences(FLastNodeDat.ObjectID); if LastRoom <> nil then DeactivateCabinetOnCAD(LastRoom.SCSID); end;} end; end; end; (* ObjID := DM.GetIDCatalogByIDFigure(AID_Figure); Catalog := TSCSCatalog.Create(TForm(F_ProjMan)); Catalog.LoadCatalogByID(ObjID, true, false); Node := nil; FirstChildNode := nil; if Catalog.SCSComponents.Count > 0 then Node := FindComponOrDirInTree(TSCSComponent(Catalog.SCSComponents.Items[0]).ID, true) else Node := FindComponOrDirInTree(ObjID, false); if Node <> nil then begin Tree_Catalog.Selected := Node; {FirstChildNode := Node.GetFirstChild; if FirstChildNode <> nil then Tree_Catalog.Selected := FirstChildNode else Tree_Catalog.Selected := Node;} end; Catalog.Free; *) end; except on E: Exception do AddExceptionToLog('ShowCatalogInPM: '+E.Message); end; end; // ##### Выделяет компонент в НБ ##### procedure SelectComponentInNB(AIDComponent: Integer); var IDTemplate: Integer; //TemplateItem: TListItem; ComponNode: TTreeNode; begin //Result := nil; try with F_NormBase do begin IDTemplate := DM.GetIntFromTable(tnTemplateRelation, fnId, fnIDComponent, AIDComponent, qmPhisical); if IDTemplate <= 0 then begin ComponNode := nil; ComponNode := FindComponOrDirInTree(AIDComponent, true); if ComponNode <> nil then Tree_Catalog.Selected := ComponNode; //Result := ComponNode; end else SelectTemplateItemByComponID(IDTemplate, AIDComponent); end; except on E: Exception do AddExceptionToLog('SelectComponentInNB: '+E.Message); end; end; function IsEmptyFigure(AIDFigure: Integer): Boolean; var //IDCatalog: Integer; SCSObject: TSCSCatalog; begin Result := true; try with F_ProjMan do begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then if SCSObject.SCSComponents.Count > 0 then Result := false; end; except on E: Exception do AddExceptionToLog('IsEmptyFigure: '+E.Message); end; end; function IsHaveObjectCableChannel(AObject: TObject): Boolean; begin Result := false; if AObject is TSCSCatalog then Result := TSCSCatalog(AObject).ComponentReferences.GetComponentByType(ctsnCableChannel) <> nil; end; function IsHaveFigureCableChannel(AListID, AFigureID: Integer): Boolean; var SCSList: TSCSList; SCSObject: TSCSCatalog; begin Result := false; SCSObject := nil; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then SCSObject := SCSList.GetCatalogFromReferencesBySCSID(AFigureID); if SCSObject <> nil then Result := IsHaveObjectCableChannel(SCSObject); end; function CheckEmptyFigure(AIDFigure: Integer): Boolean; var SCSObject: TSCSCatalog; begin Result := true; try with F_ProjMan do begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then if SCSObject.SCSComponents.Count > 0 then Result := false; end; except on E: Exception do AddExceptionToLog('CheckEmptyFigure: '+E.Message); end; end; procedure EditFirstFigureComponent(AIDFigure: Integer); var SCSObject: TSCSCatalog; SCSCompon: TSCSComponent; Node: TTreeNode; begin with F_ProjMan do begin SCSObject := nil; SCSCompon := nil; Node := nil; SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then SCSCompon := SCSObject.GetFirstComponent; if Assigned(SCSCompon) then begin //if GSCSBase.SCSComponent.ID <> SCSComponent.ID then begin if Assigned(SCSCompon.TreeViewNode) then Node := SCSCompon.TreeViewNode else Node := FindComponOrDirInTree(SCSCompon.ID, true); if Assigned(Node) {<#ForFuture#>and (Tree_Catalog.Selected <> Node)} then begin Tree_Catalog.Selected := Node; Tree_CatalogChange(Tree_Catalog, Node); end; end; if GSCSBase.SCSComponent.ID <> SCSCompon.ID then GSCSBase.SCSComponent.AssignOnlyComponent(SCSCompon); if (Node <> nil) and (Tree_Catalog.Selected = Node) then Act_EditComponent.Execute; end else if Assigned(SCSObject) then ShowMessageByType(0, smtDisplay, cBaseCommon31+' "'+SCSObject.GetNameForVisible+'" '+cBaseCommon31_2+'.', Application.Title, MB_ICONINFORMATION or MB_OK); end; end; // СОЗДАТЬ НОВЫЙ ПРОЕКТ В МП Function AddProjectInPM: TTreeNode; var TopNode: TTreeNode; NewProjectNode: TTreeNode; IDTopCatalog: Integer; ProjCount: Integer; PrjName: String; QSelect: TSCSQuery; begin Result := nil; {try with F_ProjMan do begin TopNode := GetTopNode; QSelect := TSCSQuery.Create(F_ProjMan, DM.Query_Select, DM.qSQL_QuerySelect); try QSelect.QueryMode := qmPhisical; SetSQLToQuery(QSelect, ' select Max(Mark_id) Max_Mark_ID from katalog where id_item_Type = '''+IntToStr(itProject)+''' '); ProjCount := QSelect.GetFNAsInteger('Max_Mark_ID'); finally FreeAndNil(QSelect); end; NewProjectNode := MakeDir(cfBase, TopNode, 'Проект '+IntToStr(ProjCount + 1), itProject); Result := NewProjectNode; end; except on E: Exception do AddExceptionToLog('AddProjectInPM: '+E.Message); end; } end; // ОТКРЫТЬ СУЩЕСТВУЮЩИЙ ПРОЕКТ В МП Function OpenProjectInPM(AIDLastList: Integer): TList; var ResList: TList; ptrIDAndCaption: PIDAndCaption; ListNode: TTreeNode; IDCatalogList: Integer; IDProject: Integer; //ProjCatalog: TSCSCatalog; ListCatalog: TSCSCatalog; i: Integer; TopNode: TTreeNode; ProjNode: TTreeNode; begin Result := nil; TopNode := nil; ProjNode := nil; with F_ProjMan do begin TopNode := GetTopNode; if Assigned(TopNode) then begin ProjNode := TopNode.getFirstChild; while ProjNode <> nil do begin if PObjectData(ProjNode.Data).ItemType = itProject then if PObjectData(ProjNode.Data).ObjectID = GIDLastProject then begin Tree_Catalog.Selected := ProjNode; Break; ///// BREAK ///// end; ProjNode := ProjNode.getNextSibling; end; end; end; { try //ProjCatalog := nil; if AIDLastList = 0 then Exit; ///// EXIT; ////// with F_ProjMan do begin IDCatalogList := DM.GetIDCatalogByIDList(AIDLastList); SetSQLToQuery(DM.scsQSelect, ' select parent_id, project_id from katalog where id = '''+IntToStr(IDCatalogList)+''' '); IDProject := DM.scsQSelect.GetFNAsInteger('project_id'); //GIDLastPoject := IDProject; ChangeCurrProject(GIDLastPoject, IDProject); //*** Выбрать Листы с текущего проекта ResList := TList.Create; SetSQLToQuery(DM.scsQSelect, ' select name, scs_id from katalog '+ ' where (project_id = '''+IntToStr(IDProject)+''') and (id_item_type = '''+IntToStr(itList)+''') '+ ' order by parent_id, sort_id '); while Not DM.scsQSelect.Eof do begin //New(ptrIDAndCaption); GetMem(ptrIDAndCaption, SizeOf(TIDAndCaption)); ptrIDAndCaption.ID := DM.scsQSelect.GetFNAsInteger('scs_id'); ptrIDAndCaption.Caption := DM.scsQSelect.GetFNAsString('name'); ResList.Add(ptrIDAndCaption); DM.scsQSelect.Next; end; {ProjCatalog := TSCSCatalog.Create(TForm(F_ProjMan)); ProjCatalog.LoadCatalogByID(IDProject, false); ProjCatalog.LoadChildCatalogs('scs_id'); for i := 0 to ProjCatalog.ChildCatalogs.Count - 1 do begin ptrListCatalog := ProjCatalog.ChildCatalogs.Items[i]; if ptrListCatalog.ItemType = itList then begin New(ptrIDAndCaption); ptrIDAndCaption.ID := ptrListCatalog.SCSID; ptrIDAndCaption.Caption := ptrListCatalog.Name; ResList.Add(ptrIDAndCaption); end; end; } { if ResList.Count > 0 then Result := ResList; ListNode := FindComponOrDirInTree(IDCatalogList, false); if ListNode <> nil then Tree_Catalog.Selected := ListNode; end; except on E: Exception do AddExceptionToLog('OpenProjectInPM: '+E.Message); end; } end; function GetCurrProjectName: String; begin Result := ''; with F_ProjMan do begin if GSCSBase.CurrProject.Active then Result := GSCSBase.CurrProject.Name; end; end; function CanAddListToPM(var AWasOpenProject: Boolean): Boolean; var //ListNode, TopNode: TTreeNode; //ProjNode: TTreeNode; TrgNode: TTreeNode; MayOpenProject: Boolean; begin Result := false; AWasOpenProject := false; try TrgNode := nil; TrgNode := GetTargetNodeForNewList(MayOpenProject); if Assigned(TrgNode) then begin Result := true; if MayOpenProject then if PObjectData(TrgNode.Data).ItemType = itProject then begin F_ProjMan.SwitchInCAD(TrgNode, ccDouble); AWasOpenProject := true; end; end; { with F_ProjMan do begin TopNode := F_ProjMan.GetTopNode; ListNode := nil; ListNode := F_ProjMan.Tree_Catalog.Selected; if (PObjectData(ListNode.Data).ItemType = itProject) and (PObjectData(ListNode.Data).ObjectID = GSCSBase.CurrProject.CurrID) then Result := true else begin ProjNode := GetTargetNodeForItemType(Tree_catalog.Selected, itList); if Assigned(ProjNode) then if ((PObjectData(ProjNode.Data).ItemType = itProject) and (PObjectData(ProjNode.Data).ObjectID = GSCSBase.CurrProject.CurrID)) or (PObjectData(ProjNode.Data).ItemType = itDir) then Result := true; {ListNode := nil; ListNode := F_ProjMan.FindComponOrDirInTree(GIDLastPoject, false); if (ListNode <> nil) and ((PObjectData(ListNode.Data).ItemType = itDir) or (PObjectData(ListNode.Data).ItemType = itProject)) and (ListNode <> TopNode) then Result := true; end; end; } except on E: Exception do AddExceptionToLog('CanAddListToPM: '+E.Message); end; end; // ПРИ СОЗДАНИИ ЛИСТА НА CAD-е СОЗДАТЬ ЕГО В МП function AddListInPM(AListID: Integer; AListParams: TListParams): TTreeNode; var CurrDat: PObjectData; CurrNode: TTreeNode; TopNode: TTreeNode; NewListNode: TTreeNode; MayOpenProject: Boolean; begin Result := nil; TopNode := nil; try with F_ProjMan do begin CurrDat := nil; CurrNode := nil; {CurrNode := Tree_Catalog.Selected; if Assigned(CurrNode) then begin CurrDat := CurrNode.Data; if Not (PObjectData(CurrNode.Data).ItemType in [itProject, itDir]) then begin TopNode := GetTopNode; //*** Найти ветвь текущего проекта CurrNode := nil; CurrDat := nil; CurrNode := FindComponOrDirInTree(GIDLastPoject, false); if CurrNode <> nil then CurrDat := CurrNode.Data; end; end; } CurrNode := GetTargetNodeForNewList(MayOpenProject); //*** Создать лист, если есть подходящая папка if Assigned(CurrNode) then begin //if MayOpenProject then // if PObjectData(CurrNode.Data).ItemType = itProject then // SwitchInCAD(CurrNode, ccDouble); CurrDat := CurrNode.Data; if (CurrNode <> nil) and ((CurrDat.ItemType = itDir) or (CurrDat.ItemType = itProject)) and (CurrNode <> TopNode) then begin //ChangeCurrList(GIDLastList, AListID); NewListNode := nil; NewListNode := MakeDir(cfCAD, CurrNode, AListParams.Name, itList, @AlistParams, AListID); if NewListNode <> nil then begin Tree_Catalog.Selected := NewListNode; Result := NewListNode; end; end else MessageModal(cNoSelectedDirForNewList, cImpossibleMakeList, MB_ICONINFORMATION or MB_OK); end; end; except on E: Exception do AddExceptionToLog('AddListInPM: '+E.Message); end; end; // ОТКРЫТЬ СУЩЕСТВУЮЩИЙ ЛИСТ В МП Function OpenListInPM(AListID: Integer; ALIstName: String; var AFileName: String): TMemoryStream; var //IDCatalog: integer; ListNode: TTreeNode; //ProjNode: TTreeNode; //IDTopCatalog: Integer; //ProjCount: Integer; //t: string; SCSList: TSCSList; begin Result := nil; try if AListID = 0 then Exit; ///// EXIT ///// //F_ProjMan.Tree_Catalog.Items.EndUpdate; //F_ProjMan.Tree_Catalog.Invalidate; {try t := F_ProjMan.Tree_Catalog.Items[0].Text; except end;} with F_ProjMan do begin //IDCatalog := DM.GetIDCatalogByIDList(AListID); SCSList := GSCSBase.CurrProject.GetListBySCSID(AListID); //*** Открыть найденный Лист if SCSList <> nil then //if IDCatalog <> 0 then begin SCSList.OpenedInCAD := true; ListNode := nil; ListNode := FindComponOrDirInTree(SCSList.ID, false); if (ListNode <> nil) and (AListID = GIDLastList) then begin //GIDLastList := AListID; Tree_Catalog.Selected := ListNode; end; end else //*** Создать новый проект с лимтом begin Act_MakeProject.Execute; {ProjNode := AddProjectInPM; if ProjNode <> nil then MakeDir(cfBase, ProjNode, 'Лист 1', itList);} end; Result := GetCadDataFromPM(AListID, AFileName); end; except on E: Exception do AddExceptionToLog('OpenListInPM: '+E.Message); end; end; // ПРИ ПЕРЕКЛЮЧЕНИИ ЛИСТА НА CAD-е ПЕРЕКЛЮЧИТЬ ЕГО В МП Procedure SwitchListInPM(AListID: Integer; AListName: String); var SCSList: TSCSList; Node: TTreeNode; //i: Integer; begin Node := nil; try with F_ProjMan do if Assigned(GSCSBase) and GSCSBase.Active then if Assigned(GSCSBase.CurrProject) and GSCSBase.CurrProject.Active then begin //for i := 0 to GSCSBase.CurrProject.ProjectLists.Count - 1 do // if Assigned(GSCSBase.CurrProject.ProjectLists[i].TreeViewNode) then // GSCSBase.CurrProject.ProjectLists[i].TreeViewNode.Expanded := false; if AListID <> 0 then ChangeCurrList(GIDLastList, AListID); //*** Найти лист в базе SCSList := GSCSBase.CurrProject.GetListBySCSID(AListID); if Assigned(SCSList) then begin Node := SCSList.TreeViewNode; if Node = nil then Node := FindComponOrDirInTree(SCSList.ID, false); if Node <> nil then begin Tree_Catalog.Selected := Node; //ShowSelectedNode(Tree_Catalog); end; end; end; except on E: Exception do AddExceptionToLog('SwitchListInPM: '+E.Message); end; end; procedure DeleteListInPM(AListID: Integer; AListName: String); var //CatalID: Integer; //ListNode: TTreeNode; List: TSCSList; begin try with F_ProjMan do begin //CatalID := GetIDCatalogByIDList(AListID); List := GSCSBase.CurrProject.GetListBySCSID(AListID); if List <> nil then DM.DelCatalog(cfCAD, List.ID, itList, qmMemory); //*** Удалить сохраняемые данные листа //SetSQLToQuery(scsQOperat, ' delete from cad_data where id_catalog = '''+IntToStr(CatalID)+''' '); end; except on E: Exception do AddExceptionToLog('DeleteListInPM: '+E.Message); end; end; procedure AfterCloseListInCAD(AListID: Integer); var List: TSCSList; begin List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if List <> nil then List.OpenedInCAD := false; end; function ExistsOpenedCAD: Boolean; begin Result := false; if FSCS_Main <> nil then if TForm(FSCS_Main).ActiveMDIChild <> nil then Result := true; end; function ExistsSCSObjectInList(AIDList: Integer): Boolean; var SCSList: TSCSlist; i: Integer; begin Result := false; if F_ProjMan <> nil then if F_ProjMan.GSCSBase.CurrProject.Active then begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do if SCSList.ChildCatalogReferences[i].IsLine <> biNone then begin Result := true; Break; //// BREAK //// end; end; end; procedure OpenNoExistsListInCAD(AListObject: TObject); var ListObject: TSCSList; begin try if AListObject <> nil then begin ListObject := TSCSList(AListObject); if Not ListObject.OpenedInCAD then begin if Not CheckListExist(ListObject.CurrID) then begin ProcessMessagesEx; ReopenListInCAD(ListObject.CurrID, ListObject.Name); ProcessMessagesEx; end; ListObject.OpenedInCAD := true; end; end; except on E: Exception do AddExceptionToLogEx('OpenNoExistsListInCAD', E.Message); end; end; procedure SetIsOpenedListInCADToPM(AListID: Integer; AOpened: Boolean); var ListObject: TSCSList; begin ListObject := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if ListObject <> nil then ListObject.OpenedInCAD := AOpened; end; // ##### Сохраняет условное обозначение тек-й компоненты в дереве во временный файл ##### function IconToFile(AFileName: String): TCompStateType; var ObjDat: PObjectData; StateTypeName: String; StateTypeID: String; FirstNPP: Integer; begin Result := stProjectible; (*with F_NormBase do begin ObjDat := Tree_Catalog.Selected.Data; if ObjDat.ItemType in [itComponLine, itComponCon] then begin if Not DirectoryExists('.Blk') then CreateDir('.Blk'); //*** Получить тип условного обозначения компоненты SetSQLToQuery(DM.scsQ, ' SELECT PVALUE FROM COMP_PROP_RELATION '+ ' WHERE (ID_PROPERTY IN (SELECT ID FROM PROPERTIES '+ ' WHERE ID_DATA_TYPE = '''+ IntToStr(dtCompStateType) +''' ) ) and '+ ' (ID_COMPONENT = '''+ IntToStr(ObjDat.ObjectID) +''') ' ); StateTypeID := DM.scsQ.GetFNAsString('PValue'); if StateTypeID = '' then Exit; ///// EXIT ///// //*** Обределить название типа усл.-го обозначения SetSQLToQuery(DM.scsQ, ' SELECT NAME FROM COMP_STATE_TYPE WHERE ID = '+ StateTypeID +' '); StateTypeName := AnsiLowerCase(DM.scsQ.GetFNAsString('Name')); //*** Определить 1-й № условного обозначения компоненты SetSQLToQuery(DM.scsQ, ' SELECT MIN(NPP_ID) FROM OBJECT_ICONS '+ ' WHERE ID IN (SELECT ID_OBJECT_ICON FROM COMPONENT_ICONS '+ ' WHERE ID_COMPONENT = '''+ IntToStr(ObjDat.ObjectID) +''') '); FirstNPP := DM.scsQ.GetFNAsInteger('MIN'); //*** Забросить иконку в файл SetSQLToQuery(DM.scsQ, ' SELECT BLOCK, NAME FROM OBJECT_ICONS, COMP_STATE_TYPE '+ ' WHERE (NPP_ID = '''+ IntToStr(FirstNPP) +''') AND (ID_COMP_STATE_TYPE = '+ StateTypeID +') AND (ID_COMP_STATE_TYPE = COMP_STATE_TYPE.ID) '); {SetSQLToQuery(DM.scsQ, ' SELECT BLOCK FROM OBJECT_ICONS '+ ' WHERE ID IN (SELECT ID_OBJECT_ICON FROM COMPONENT_ICONS '+ ' WHERE ID_COMPONENT = '''+ IntToStr(ObjDat.ObjectID) +''') ');} DM.scsQ.FNSaveToFile('Block', '.blk\'+ AfileName +'.blk'); if StateTypeName = 'проектируемый' then Result := stProjectible; if StateTypeName = 'действующий' then Result := stActing; end; end; *) end; // ##### Вернет список компонентов, кот-е соединяют AIDServerCompon и AIDWSCompon, // не включая AIDServerCompon и AIDWSCompon ##### function GetJoinComponsIDs(AServerCompon, AWSCompon: TObject; var AResLength: Double; AThroughPointCompon: Boolean): TIntList; var CurrIDPathList: TIntList; CurrLength: Double; LookedID: TIntList; LastIDPathList: TIntList; LastLength: Double; IDCompon: Integer; Res: Boolean; ResultList: TIntlist; //ptrIDCompon: ^Integer; i: Integer; IDAutoTracingProperty: Integer; IDAutoTracingPropertyStr: String; IDPropLength: Integer; strComponLength: String; InOrderIndex: Integer; F: File of string[50]; FStr: String[50]; procedure Step(ASourceWS: TObject; AInOrder: TIntList; ATraveledIndex: Integer); var ConnectedIDList: TIntList; InOrderList: TIntList; i: Integer; //16.01.2013 IDConn: Integer; ComponLength: Double; SrcComponent, JoinedCompon: TSCSComponent; begin //## New {if Not CheckNoIDinList(AIDSourceWS, LookedID) then Exit; //// EXIT //// } // End New ## SrcComponent := nil; SrcComponent := TSCSComponent(ASourceWS); //F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDSourceWS); if Assigned(SrcComponent) then begin //if (SrcComponent.IsLine = biFalse) or (SrcComponent.GetPropertyValueAsInteger(pnAutotracing) = biTrue) then //}if CheckAutoTracing(AIDSourceWS, IDAutoTracingPropertyStr) then begin ComponLength := 0; {if isLineCompon(F_ProjMan.DM.scsQSelect, AIDSourceWS) then ComponLength := F_ProjMan.GetPropertyValueAsFloat(tkComponent, AIDSourceWS, pnLength);} //*** Определить длину текущей компоненты if SrcComponent.IsLine = biTrue then begin SrcComponent.RefreshWholeLengthIfNecessary; ComponLength := SrcComponent.Length; //17.01.2013 ComponLength := SrcComponent.GetPropertyValueAsFloat(pnLength); end; //with F_ProjMan.DM do // begin // strComponLength := GetCompPropRelFieldValueAsStringByFilter(fnPValue, '(id_property = '''+IntToStr(IDPropLength)+''') and '+ // '(id_component = '''+IntToStr(AIDSourceWS)+''')'); // if strComponLength <> '' then // ComponLength := StrToFloat_My(strComponLength); // end; if ComponLength > 0 then CurrLength := ComponLength; //CurrLength := CurrLength + ComponLength; //New(IDCompon); //GetMem(IDCompon, SizeOf(Integer)); //IDCompon^ := AIDSourceWS; CurrIDPathList.Add(SrcComponent.ID); //FStr := IntToStr(AIDSourceWS) + ' - ' + IntToStr(AIDServerCompon); //Write(F, FStr); if (ASourceWS = AWSCompon) {and ((CurrLength < LastLength) or (LastLength = 0) )} then begin if (CurrLength < LastLength) or (LastLength = 0) then begin //FStr := '******** FINDED *****'+#13+#13; //Write(F, FStr); //*** Переприсвоить кратчайшый путь LookedID.Clear; //ClearList(LookedID); LastIDPathList.Clear; //ClearList(LastIDPathList); for i := 0 to CurrIDPathList.Count - 1 do begin //New(ptrIDCompon); //GetMem(ptrIDCompon, SizeOf(Integer)); //ptrIDCompon^ := Integer(CurrIDPathList.Items[i]^); LastIDPathList.Add(CurrIDPathList[i]); end; //*** Переприсвоить кратчайшую длину LastLength := CurrLength; end; end else if (SrcComponent.IsLine = biTrue) or AThroughPointCompon or (ASourceWS = AServerCompon) or (ASourceWS = AWSCompon) then begin //16.01.2013 ConnectedIDList := TIntList.Create; //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_component', 'id_child'); //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_child', 'id_component'); //16.01.2013 //*** Определить подсоединенные компоненты //for i := 0 to SrcComponent.JoinedComponents.Count - 1 do // if Assigned(SrcComponent.JoinedComponents[i]) then // begin // ConnectedIDList.Add(SrcComponent.JoinedComponents[i].ID); // end; InOrderList := TIntList.Create; //16.01.2013 InOrderList.Assign(ConnectedIDList, laOr); //16.01.2013 if AInOrder <> nil then //16.01.2013 InOrderList.Assign(AInOrder, laOr); if AInOrder <> nil then InOrderList.Assign(AInOrder); for i := 0 to SrcComponent.JoinedComponents.Count - 1 do if InOrderList.IndexOf(SrcComponent.JoinedComponents[i].ID) = -1 then InOrderList.Add(SrcComponent.JoinedComponents[i].ID); //*** Пройти по подсоединеннім компонентам for i := 0 to SrcComponent.JoinedComponents.Count - 1 do begin JoinedCompon := SrcComponent.JoinedComponents[i]; if ((AInOrder = nil) or (AInOrder.IndexOf(JoinedCompon.ID) = -1)) and (CurrIDPathList.IndexOf(JoinedCompon.ID) = -1) then //if CheckNoIDinList(IDConn^, AInOrder) and // CheckNoIDinList(IDConn^, CurrIDPathList) then begin Step(JoinedCompon, InOrderList, ATraveledIndex + 1); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laOr); //Step(IDConn, ConnectedIDList, ATraveledIndex + 1); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laXor); end; end; InOrderList.Free; //16.01.2013 ConnectedIDList.Free; //FreeList(ConnectedIDList); end; CurrLength := CurrLength - ComponLength; //FreeMem(CurrIDPathList.Items[ATraveledIndex]); if (CurrIDPathList.Count-1) <> ATraveledIndex then EmptyProcedure; CurrIDPathList.Delete(ATraveledIndex); end; end; end; begin Result := nil; CurrIDPathList := TIntlist.Create; CurrLength := 0; LookedID := TIntlist.Create; LastIDPathList := TIntlist.Create; LastLength := 0; try //GDragPrevTickCount := GetTickCount; //*** Рекурсивный поиск Step(AServerCompon, nil, 0); //if Res = true then begin ResultList := TIntList.Create; for i := 0 to LastIDPathList.Count - 1 do begin IDCompon := LastIDPathList.Items[i]; if (TSCSComponent(AServerCompon).ID <> IDCompon) and (TSCSComponent(AWSCompon).ID <> IDCompon) then begin //GetMem(ptrIDCompon, SizeOf(Integer)); //ptrIDCompon^ := IDCompon^; ResultList.Add(IDCompon); end; end; AResLength := LastLength; if ResultList.Count = 0 then ResultList.Free else Result := ResultList; end; except on E: Exception do AddExceptionToLog('GetJoinComponsIDs: '+E.Message); end; CurrIDPathList.Free; //FreeList(CurrIDPathList); LookedID.Free; //FreeList(LookedID); LastIDPathList.Free; //FreeList(LastIDPathList); end; (* function GetJoinComponsIDs(AIDServerCompon, AIDWSCompon: Integer; var AResLength: Double; AThroughPointCompon: Boolean): TIntList; var CurrIDPathList: TIntList; CurrLength: Double; LookedID: TIntList; LastIDPathList: TIntList; LastLength: Double; IDCompon: Integer; Res: Boolean; ResultList: TIntlist; //ptrIDCompon: ^Integer; i: Integer; IDAutoTracingProperty: Integer; IDAutoTracingPropertyStr: String; IDPropLength: Integer; strComponLength: String; InOrderIndex: Integer; F: File of string[50]; FStr: String[50]; procedure Step(AIDSourceWS: Integer; AInOrder: TIntList; ATraveledIndex: Integer); var ConnectedIDList: TIntList; InOrderList: TIntList; i: Integer; IDConn: Integer; ComponLength: Double; SrcComponent: TSCSComponent; begin //## New {if Not CheckNoIDinList(AIDSourceWS, LookedID) then Exit; //// EXIT //// } // End New ## SrcComponent := nil; SrcComponent := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDSourceWS); if Assigned(SrcComponent) then begin //if (SrcComponent.IsLine = biFalse) or (SrcComponent.GetPropertyValueAsInteger(pnAutotracing) = biTrue) then //}if CheckAutoTracing(AIDSourceWS, IDAutoTracingPropertyStr) then begin ComponLength := 0; {if isLineCompon(F_ProjMan.DM.scsQSelect, AIDSourceWS) then ComponLength := F_ProjMan.GetPropertyValueAsFloat(tkComponent, AIDSourceWS, pnLength);} //*** Определить длину текущей компоненты if SrcComponent.IsLine = biTrue then begin SrcComponent.RefreshWholeLengthIfNecessary; ComponLength := SrcComponent.GetPropertyValueAsFloat(pnLength); end; //with F_ProjMan.DM do // begin // strComponLength := GetCompPropRelFieldValueAsStringByFilter(fnPValue, '(id_property = '''+IntToStr(IDPropLength)+''') and '+ // '(id_component = '''+IntToStr(AIDSourceWS)+''')'); // if strComponLength <> '' then // ComponLength := StrToFloat_My(strComponLength); // end; if ComponLength > 0 then CurrLength := ComponLength; //CurrLength := CurrLength + ComponLength; //New(IDCompon); //GetMem(IDCompon, SizeOf(Integer)); //IDCompon^ := AIDSourceWS; CurrIDPathList.Add(AIDSourceWS); //FStr := IntToStr(AIDSourceWS) + ' - ' + IntToStr(AIDServerCompon); //Write(F, FStr); if (AIDSourceWS = AIDWSCompon) {and ((CurrLength < LastLength) or (LastLength = 0) )} then begin if (CurrLength < LastLength) or (LastLength = 0) then begin //FStr := '******** FINDED *****'+#13+#13; //Write(F, FStr); //*** Переприсвоить кратчайшый путь LookedID.Clear; //ClearList(LookedID); LastIDPathList.Clear; //ClearList(LastIDPathList); for i := 0 to CurrIDPathList.Count - 1 do begin //New(ptrIDCompon); //GetMem(ptrIDCompon, SizeOf(Integer)); //ptrIDCompon^ := Integer(CurrIDPathList.Items[i]^); LastIDPathList.Add(CurrIDPathList[i]); end; //*** Переприсвоить кратчайшую длину LastLength := CurrLength; end; end else if (SrcComponent.IsLine = biTrue) or AThroughPointCompon or (AIDSourceWS = AIDServerCompon) or (AIDSourceWS = AIDWSCompon) then begin ConnectedIDList := TIntList.Create; //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_component', 'id_child'); //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_child', 'id_component'); //*** Определить подсоединенные компоненты for i := 0 to SrcComponent.JoinedComponents.Count - 1 do if Assigned(SrcComponent.JoinedComponents[i]) then begin ConnectedIDList.Add(SrcComponent.JoinedComponents[i].ID); end; InOrderList := TIntList.Create; InOrderList.Assign(ConnectedIDList, laOr); if AInOrder <> nil then InOrderList.Assign(AInOrder, laOr); //*** Пройти по подсоединеннім компонентам for i := 0 to ConnectedIDList.Count - 1 do begin IDConn := ConnectedIDList[i]; if ((AInOrder = nil) or (AInOrder.IndexOf(IDConn) = -1)) and (CurrIDPathList.IndexOf(IDConn) = -1) then //if CheckNoIDinList(IDConn^, AInOrder) and // CheckNoIDinList(IDConn^, CurrIDPathList) then begin Step(IDConn, InOrderList, ATraveledIndex + 1); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laOr); //Step(IDConn, ConnectedIDList, ATraveledIndex + 1); //if AInOrder <> nil then // ConnectedIDList.Assign(AInOrder, laXor); end; end; InOrderList.Free; ConnectedIDList.Free; //FreeList(ConnectedIDList); end; CurrLength := CurrLength - ComponLength; //FreeMem(CurrIDPathList.Items[ATraveledIndex]); if (CurrIDPathList.Count-1) <> ATraveledIndex then EmptyProcedure; CurrIDPathList.Delete(ATraveledIndex); end; end; end; begin Result := nil; try try CurrIDPathList := TIntlist.Create; CurrLength := 0; LookedID := TIntlist.Create; LastIDPathList := TIntlist.Create; LastLength := 0; //GDragPrevTickCount := GetTickCount; { with F_NormBase.DM do begin //*** Найти ID свойства авторокладки IDAutoTracingProperty := F_NormBase.DM.GetIDPropertyBySysName(tkComponent, -1, pnAutotracing, itNone); //SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); //IDAutoTracingPropertyStr := IntToStr(scsQSelect.GetFNAsInteger('id')); //*** Найти ID свойства длина IDPropLength := F_NormBase.DM.GetIDPropertyBySysName(tkComponent, -1, pnLength, itNone); //SetSQLToQuery(scsQSelect, ' select id from properties '+ // ' where (sysname = '''+pnLength+''') and (id_item_type = '''+IntToStr(itComponent)+''') '); //IDPropLength := scsQSelect.GetFNAsInteger('id'); end;} //*** Рекурсивный поиск Step(AIDServerCompon, nil, 0); //if Res = true then begin ResultList := TIntList.Create; for i := 0 to LastIDPathList.Count - 1 do begin IDCompon := LastIDPathList.Items[i]; if (AIDServerCompon <> IDCompon) and (AIDWSCompon <> IDCompon) then begin //GetMem(ptrIDCompon, SizeOf(Integer)); //ptrIDCompon^ := IDCompon^; ResultList.Add(IDCompon); end; end; AResLength := LastLength; if ResultList.Count = 0 then ResultList.Free else Result := ResultList; end; except on E: Exception do AddExceptionToLog('GetJoinComponsIDs: '+E.Message); end; finally CurrIDPathList.Free; //FreeList(CurrIDPathList); LookedID.Free; //FreeList(LookedID); LastIDPathList.Free; //FreeList(LastIDPathList); end; end; *) (* function GetJoinComponsIDs(AIDServerCompon, AIDWSCompon: Integer; var AResLength: Double): TList; var CurrIDPathList: TList; CurrLength: Double; LookedID: TList; LastIDPathList: TList; LastLength: Double; IDCompon: ^Integer; Res: Boolean; ResultList: Tlist; ptrIDCompon: ^Integer; i: Integer; IDAutoTracingPropertyStr: String; IDPropLength: Integer; strComponLength: String; InOrderIndex: Integer; F: File of string[50]; FStr: String[50]; procedure Step(AIDSourceWS: Integer; AInOrder: TList; ATraveledIndex: Integer); var ConnectedIDList: TList; i: Integer; IDConn: ^Integer; ComponLength: Double; begin //## New {if Not CheckNoIDinList(AIDSourceWS, LookedID) then Exit; //// EXIT //// } // End New ## if CheckAutoTracing(AIDSourceWS, IDAutoTracingPropertyStr) then begin ComponLength := 0; {if isLineCompon(F_ProjMan.DM.scsQSelect, AIDSourceWS) then ComponLength := F_ProjMan.GetPropertyValueAsFloat(tkComponent, AIDSourceWS, pnLength);} //*** Определить длину текущей компоненты if isLineCompon(TForm(F_ProjMan), AIDSourceWS) then with F_ProjMan.DM do begin strComponLength := GetCompPropRelFieldValueAsStringByFilter(fnPValue, '(id_property = '''+IntToStr(IDPropLength)+''') and '+ '(id_component = '''+IntToStr(AIDSourceWS)+''')'); if strComponLength <> '' then ComponLength := StrToFloat_My(strComponLength); end; if ComponLength > 0 then CurrLength := ComponLength; //CurrLength := CurrLength + ComponLength; //New(IDCompon); GetMem(IDCompon, SizeOf(Integer)); IDCompon^ := AIDSourceWS; CurrIDPathList.Add(IDCompon); //FStr := IntToStr(AIDSourceWS) + ' - ' + IntToStr(AIDServerCompon); //Write(F, FStr); if (AIDSourceWS = AIDWSCompon) and ((CurrLength < LastLength) or (LastLength = 0) ) then begin //FStr := '******** FINDED *****'+#13+#13; //Write(F, FStr); //*** Переприсвоить кратчайшый путь ClearList(LookedID); ClearList(LastIDPathList); for i := 0 to CurrIDPathList.Count - 1 do begin //New(ptrIDCompon); GetMem(ptrIDCompon, SizeOf(Integer)); ptrIDCompon^ := Integer(CurrIDPathList.Items[i]^); LastIDPathList.Add(ptrIDCompon); end; //*** Переприсвоить кратчайшую длину LastLength := CurrLength; end else begin ConnectedIDList := TList.Create; //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_component', 'id_child'); //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_child', 'id_component'); //*** Определить подсоединенные компоненты with F_ProjMan.DM do begin SetFilterToSQLMemTable(tSQL_ComponentRelation, '((id_component = '''+IntTostr(AIDSourceWS)+''') or (id_child = '''+IntTostr(AIDSourceWS)+''')) and '+ '(connect_type = '''+IntToStr(cntUnion)+''')'); tSQL_ComponentRelation.First; while Not tSQL_ComponentRelation.Eof do begin //New(ptrIDCompon); GetMem(ptrIDCompon, SizeOf(Integer)); ptrIDCompon^ := tSQL_ComponentRelation.FieldByName(fnIDChild).AsInteger; ConnectedIDList.Add(ptrIDCompon); //New(ptrIDCompon); GetMem(ptrIDCompon, SizeOf(Integer)); ptrIDCompon^ := tSQL_ComponentRelation.FieldByName(fnIDComponent).AsInteger; ConnectedIDList.Add(ptrIDCompon); tSQL_ComponentRelation.Next; end; end; //*** Пройти по подсоединеннім компонентам for i := 0 to ConnectedIDList.Count - 1 do begin IDConn := ConnectedIDList.Items[i]; if CheckNoIDinList(IDConn^, AInOrder) and CheckNoIDinList(IDConn^, CurrIDPathList) then begin if AInOrder <> nil then ConnectedIDList.Assign(AInOrder, laOr); Step(IDConn^, ConnectedIDList, ATraveledIndex + 1); if AInOrder <> nil then ConnectedIDList.Assign(AInOrder, laXor); end; end; FreeList(ConnectedIDList); end; CurrLength := CurrLength - ComponLength; FreeMem(CurrIDPathList.Items[ATraveledIndex]); CurrIDPathList.Delete(ATraveledIndex); //FreeMem(CurrIDPathList.Items[CurrIDPathList.count - 1]); //CurrIDPathList.Delete(CurrIDPathList.count - 1); // ### New { if (AIDSourceWS <> AIDServerCompon) and (AIDSourceWS <> AIDWSCompon) then begin New(ptrIDCompon); ptrIDCompon^ := AIDSourceWS; //IDConn^; LookedID.Add(ptrIDCompon); end; } // End New ### end; end; begin Result := nil; try try CurrIDPathList := Tlist.Create; CurrLength := 0; LookedID := Tlist.Create; LastIDPathList := Tlist.Create; LastLength := 0; //GDragPrevTickCount := GetTickCount; with F_NormBase.DM do begin //*** Найти ID свойства авторокладки SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); IDAutoTracingPropertyStr := IntToStr(scsQSelect.GetFNAsInteger('id')); //*** Найти ID свойства длина SetSQLToQuery(scsQSelect, ' select id from properties '+ ' where (sysname = '''+pnLength+''') and (id_item_type = '''+IntToStr(itComponent)+''') '); IDPropLength := scsQSelect.GetFNAsInteger('id'); end; //*** Рекурсивный поиск Step(AIDServerCompon, nil, 0); //if Res = true then begin ResultList := TList.Create; for i := 0 to LastIDPathList.Count - 1 do begin IDCompon := LastIDPathList.Items[i]; if (AIDServerCompon <> IDCompon^) and (AIDWSCompon <> IDCompon^) then begin //New(ptrIDCompon); GetMem(ptrIDCompon, SizeOf(Integer)); ptrIDCompon^ := IDCompon^; ResultList.Add(ptrIDCompon); end; end; AResLength := LastLength; if ResultList.Count = 0 then ResultList.Free else Result := ResultList; end; except on E: Exception do AddExceptionToLog('GetJoinComponsIDs: '+E.Message); end; finally FreeList(CurrIDPathList); FreeList(LookedID); FreeList(LastIDPathList); end; end; *) (* function GetJoinComponsIDs(AIDServerCompon, AIDWSCompon: Integer; var AResLength: Double): TList; var CurrIDPathList: TList; CurrLength: Double; LookedID: TList; LastIDPathList: TList; LastLength: Double; IDCompon: ^Integer; Res: Boolean; ResultList: Tlist; ptrIDCompon: ^Integer; i: Integer; IDAutoTracingPropertyStr: String; IDPropLength: Integer; strComponLength: String; InOrderIndex: Integer; F: File of string[50]; FStr: String[50]; procedure Step(AIDSourceWS: Integer; AInOrder: TList; ATraveledIndex: Integer); var ConnectedIDList: TList; i: Integer; IDConn: ^Integer; ComponLength: Double; begin //## New {if Not CheckNoIDinList(AIDSourceWS, LookedID) then Exit; //// EXIT //// } // End New ## if CheckAutoTracing(AIDSourceWS, IDAutoTracingPropertyStr) then begin ComponLength := 0; {if isLineCompon(F_ProjMan.DM.scsQSelect, AIDSourceWS) then ComponLength := F_ProjMan.GetPropertyValueAsFloat(tkComponent, AIDSourceWS, pnLength);} //*** Определить длину текущей компоненты if isLineCompon(TForm(F_ProjMan), AIDSourceWS) then with F_ProjMan.DM do begin scsQ1.Close; scsQ1.SetParamAsInteger('id_component', AIDSourceWS); scsQ1.ExecQuery; strComponLength := scsQ1.GetFNAsString('pvalue'); if strComponLength <> '' then ComponLength := StrToFloat_My(strComponLength); end; if ComponLength > 0 then CurrLength := ComponLength; //CurrLength := CurrLength + ComponLength; New(IDCompon); IDCompon^ := AIDSourceWS; CurrIDPathList.Add(IDCompon); //FStr := IntToStr(AIDSourceWS) + ' - ' + IntToStr(AIDServerCompon); //Write(F, FStr); if (AIDSourceWS = AIDWSCompon) and ((CurrLength < LastLength) or (LastLength = 0) ) then begin //FStr := '******** FINDED *****'+#13+#13; //Write(F, FStr); //*** Переприсвоить кратчайшый путь ClearList(LookedID); ClearList(LastIDPathList); for i := 0 to CurrIDPathList.Count - 1 do begin New(ptrIDCompon); ptrIDCompon^ := Integer(CurrIDPathList.Items[i]^); LastIDPathList.Add(ptrIDCompon); end; //*** Переприсвоить кратчайшую длину LastLength := CurrLength; end else begin ConnectedIDList := TList.Create; //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_component', 'id_child'); //SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_child', 'id_component'); //*** Определить подсоединенные компоненты with F_ProjMan.DM do begin scsQ.Close; scsQ.SetParamAsInteger('id_comp', AIDSourceWS); scsQ.ExecQuery; while Not scsQ.Eof do begin New(ptrIDCompon); ptrIDCompon^ := scsQ.GetFNAsInteger('id_child'); ConnectedIDList.Add(ptrIDCompon); New(ptrIDCompon); ptrIDCompon^ := scsQ.GetFNAsInteger('id_component'); ConnectedIDList.Add(ptrIDCompon); scsQ.Next; end {IntFieldToList(ConnectedIDList, scsQ, 'id_component'); scsQ.Bof := true; IntFieldToList(ConnectedIDList, scsQ, 'id_child');} end; //*** Пройти по подсоединеннім компонентам for i := 0 to ConnectedIDList.Count - 1 do begin IDConn := ConnectedIDList.Items[i]; if CheckNoIDinList(IDConn^, AInOrder) and CheckNoIDinList(IDConn^, CurrIDPathList) then begin if AInOrder <> nil then ConnectedIDList.Assign(AInOrder, laOr); Step(IDConn^, ConnectedIDList, ATraveledIndex + 1); if AInOrder <> nil then ConnectedIDList.Assign(AInOrder, laXor); end; end; FreeList(ConnectedIDList); end; CurrLength := CurrLength - ComponLength; FreeMem(CurrIDPathList.Items[ATraveledIndex]); CurrIDPathList.Delete(ATraveledIndex); //FreeMem(CurrIDPathList.Items[CurrIDPathList.count - 1]); //CurrIDPathList.Delete(CurrIDPathList.count - 1); // ### New { if (AIDSourceWS <> AIDServerCompon) and (AIDSourceWS <> AIDWSCompon) then begin New(ptrIDCompon); ptrIDCompon^ := AIDSourceWS; //IDConn^; LookedID.Add(ptrIDCompon); end; } // End New ### end; end; begin Result := nil; try try CurrIDPathList := Tlist.Create; CurrLength := 0; LookedID := Tlist.Create; LastIDPathList := Tlist.Create; LastLength := 0; //GDragPrevTickCount := GetTickCount; with F_NormBase.DM do begin //*** Найти ID свойства авторокладки SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); IDAutoTracingPropertyStr := IntToStr(scsQSelect.GetFNAsInteger('id')); //*** Найти ID свойства длина SetSQLToQuery(scsQSelect, ' select id from properties '+ ' where (sysname = '''+pnLength+''') and (id_item_type = '''+IntToStr(itComponent)+''') '); IDPropLength := scsQSelect.GetFNAsInteger('id'); end; //*** Запрос для поиска длины компоненты ChangeSQLQuery(F_ProjMan.DM.scsQ1, ' select PValue from comp_prop_relation '+ ' where (id_property = '''+IntToStr(IDPropLength)+''') and '+ ' (id_component = :id_component) '); //*** Запрос для поиска соединеных компонентов ChangeSQLQuery(F_ProjMan.DM.scsQ, ' select id_component, id_child from component_relation '+ ' where ((id_component = :id_comp) or (id_child = :id_comp)) and '+ ' (connect_type = '''+IntToStr(cntUnion)+''') '); //*** Рекурсивный поиск Step(AIDServerCompon, nil, 0); //if Res = true then begin ResultList := TList.Create; for i := 0 to LastIDPathList.Count - 1 do begin IDCompon := LastIDPathList.Items[i]; if (AIDServerCompon <> IDCompon^) and (AIDWSCompon <> IDCompon^) then begin New(ptrIDCompon); ptrIDCompon^ := IDCompon^; ResultList.Add(ptrIDCompon); end; end; AResLength := LastLength; if ResultList.Count = 0 then ResultList.Free else Result := ResultList; end; except on E: Exception do AddExceptionToLog('GetJoinComponsIDs: '+E.Message); end; finally FreeList(CurrIDPathList); FreeList(LookedID); FreeList(LastIDPathList); end; end; *) { function GetJoinComponsIDs(AIDServerCompon, AIDWSCompon: Integer): TList; var IDPathList: TList; IDCompon: ^Integer; Res: Boolean; ResultList: Tlist; ptrIDCompon: ^Integer; i: Integer; IDAutoTracingPropertyStr: String; function Step(AIDSourceWS: Integer; AInOrder: TList; ATraveledIndex: Integer): Boolean; var ConnectedIDList: TList; i: Integer; IDConn: ^Integer; StepRes: Boolean; begin Result := false; StepRes := false; if CheckAutoTracing(AIDSourceWS, IDAutoTracingPropertyStr) then begin New(IDCompon); IDCompon^ := AIDSourceWS; IDPathList.Add(IDCompon); if AIDSourceWS = AIDWSCompon then Result := true else begin ConnectedIDList := TList.Create; SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_component', 'id_child'); SelectConnByField(ConnectedIDList, AIDSourceWS, 'id_child', 'id_component'); for i := 0 to ConnectedIDList.Count - 1 do begin IDConn := ConnectedIDList.Items[i]; if CheckNoIDinList(IDConn^, AInOrder) and CheckNoIDinList(IDConn^, IDPathList) then StepRes := Step(IDConn^, ConnectedIDList, ATraveledIndex + 1); if StepRes = true then Break; end; if Not StepRes then begin FreeMem(IDPathList.Items[ATraveledIndex]); IDPathList.Delete(ATraveledIndex); end; FreeList(ConnectedIDList); Result := StepRes; end; end; end; begin Result := nil; IDPathList := Tlist.Create; //GDragPrevTickCount := GetTickCount; //*** Найти ID свойства авторокладки with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); IDAutoTracingPropertyStr := IntToStr(scsQSelect.FN('id').AsInteger); end; Res := Step(AIDServerCompon, nil, 0); if Res = true then begin ResultList := TList.Create; for i := 0 to IDPathList.Count - 1 do begin IDCompon := IDPathList.Items[i]; if (AIDServerCompon <> IDCompon^) and (AIDWSCompon <> IDCompon^) then begin New(ptrIDCompon); ptrIDCompon^ := IDCompon^; ResultList.Add(ptrIDCompon); end; end; Result := ResultList; end; FreeList(IDPathList); end; } // ##### Вернет список компонентов, кот-е соединяют AIDServerCompon и AIDWSCompon, // не включая AIDServerCompon и AIDWSCompon, учитывая их компл-е ##### function GetJoinComponsIDsAccountComplects(AIDServerCompon, AIDWSCompon: Integer; var AResLength: Double): TIntList; var CurrList: TIntList; LastList: TIntList; CurrLength: Double; lastLength: Double; ServerCompon: TSCSComponent; WSCompon: TSCSComponent; ServerListID: TList; //*** Id-ки сервера и его комплектующих WSListID: TList; //*** Id-ки рабочей станции и ее комплектующих i, j, k: Integer; ServID: Integer; WSID: Integer; //ptrID: ^Integer; function ComponInConnect(AIDComponent: Integer): Boolean; var strIDCompon: String; begin Result := false; strIDCompon := IntToStr(AIDComponent); with F_ProjMan.DM do begin SetSQLToQuery(scsQSelect, ' select count(id) As Cnt from component_relation '+ ' where ((id_component = '''+strIDCompon+''') or '+ ' (id_child = '''+strIDCompon+''')) and '+ ' (connect_type = '''+IntToStr(cntUnion)+''') '); if scsQSelect.GetFNAsInteger('Cnt') > 0 then Result := true; end; end; begin Result := nil; try CurrList := nil; LastList := TIntList.Create; CurrLength := 0; LastLength := 0; ServerCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDServerCompon); WSCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(AIDWSCompon); if Assigned(ServerCompon) and Assigned(WSCompon) then try for i := 0 to WSCompon.ChildReferences.Count - 1 do if Assigned(WSCompon.ChildReferences[i]) then for j := 0 to ServerCompon.ChildReferences.Count - 1 do if Assigned(ServerCompon.ChildReferences[j]) then begin //16.01.2013 CurrList := GetJoinComponsIDs(ServerCompon.ChildReferences[j].ID, WSCompon.ChildReferences[i].ID, CurrLength, false); CurrList := GetJoinComponsIDs(ServerCompon.ChildReferences[j], WSCompon.ChildReferences[i], CurrLength, false); //*** Переприсвоить краткий путь if CurrList <> nil then begin if (CurrLength <= LastLength) or (lastLength = 0) then begin //ClearList(LastList); LastList.Clear; for k := 0 to CurrList.Count - 1 do begin //New(ptrID); //GetMem(ptrID, SizeOf(Integer)); //ptrID^ := Integer(CurrList.Items[k]^); LastList.Add(CurrList[k]); end; lastLength := CurrLength; end; end else CurrList.Free; //FreeList(CurrList); end; AResLength := lastLength; if LastList.Count = 0 then LastList.Free else Result := LastList; finally CurrList.Free; //FreeList(CurrList); end; (* ServerCompon := TSCSComponent.Create(TForm(F_ProjMan)); WSCompon := TSCSComponent.Create(TForm(F_ProjMan)); try ServerCompon.ID := AIDServerCompon; ServerListID := ServerCompon.GetIDListWithAllSCSComplects(true); WSCompon.ID := AIDWSCompon; WSListID := WSCompon.GetIDListWithAllSCSComplects(true); if (ServerListID <> nil) and (WSListID <> nil) then for i := 0 to WSListID.Count - 1 do begin WSID := Integer(WSListID.Items[i]^); if ComponInConnect(WSID) then for j := 0 to ServerListID.Count - 1 do begin ServID := Integer(ServerListID.Items[j]^); if ComponInConnect(ServID) then begin CurrList := GetJoinComponsIDs(ServID, WSID, CurrLength); //*** Переприсвоить краткий путь if CurrList <> nil then begin if (CurrLength <= LastLength) or (lastLength = 0) then begin ClearList(LastList); for k := 0 to CurrList.Count - 1 do begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := Integer(CurrList.Items[k]^); LastList.Add(ptrID); end; lastLength := CurrLength; end; end else FreeList(CurrList); {if ResList <> nil then begin Result := ResList; Exit; ///// EXIT ///// end;} end; end; end; AResLength := lastLength; if LastList.Count = 0 then LastList.Free else Result := LastList; finally ServerCompon.Free; WSCompon.Free; FreeList(CurrList); end; *) except on E: Exception do AddExceptionToLog('GetJoinComponsIDsAccountComplects: '+E.Message); end; end; function GetComponentsJoiningCatalogs(ASCSIDCatalog1, ASCSIDCatalog2: Integer; var AResLength: Double): TIntList; var ServerCatalog: TSCSCatalog; WSCatalog: TSCSCatalog; ServerCompon: TSCSComponent; WSCompon: TSCSComponent; ReplaseParams: Boolean; CurrList: TIntlist; LastList: TIntList; CurrLength: Double; LastLength: Double; i, j, k: Integer; //ptrID: ^Integer; ComponentsFromServer: TSCSComponents; ComponentsFromWS: TSCSComponents; // Tolik 28/08/2019 - - //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // begin Result := nil; OldTick := GetTickCount; try CurrList := nil; LastList := TIntList.Create; ServerCatalog := nil; WSCatalog := nil; //ServerCatalog := TSCSCatalog.Create(F_ProjMan); //WSCatalog := TSCSCatalog.Create(F_ProjMan); try CurrLength := 0; LastLength := 0; with F_ProjMan do begin ReplaseParams := false; ServerCatalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(ASCSIDCatalog1); WSCatalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(ASCSIDCatalog2); if Assigned(ServerCatalog) and Assigned(WSCatalog) then begin ComponentsFromServer := GetCatalogComponentsJoinedToNoPoint(ServerCatalog); ComponentsFromWS := GetCatalogComponentsJoinedToNoPoint(WSCatalog); //ComponentsFromCatalog2: TSCSComponents; //ServerCatalog.LoadAllComponents(AIDCatalog1, false); //WSCatalog.LoadAllComponents(AIDCatalog2, false); if ComponentsFromServer.Count < ComponentsFromWS.Count then ReplaseParams := true; //*** Проверить есть ли компоненты соед-е for i := 0 to ComponentsFromServer.Count - 1 do begin ServerCompon := ComponentsFromServer.Items[i]; if ServerCompon.JoinedComponents.Count > 0 then //if ComponInConnect(ServerCompon.ID) then for j := 0 to ComponentsFromWS.Count - 1 do begin {if (GetKeyState(VK_ESCAPE) and 128) = 0 then begin Exit; ///// EXIT ///// end;} WSCompon := ComponentsFromWS.Items[j]; if WSCompon.JoinedComponents.Count > 0 then //if ComponInConnect(WSCompon.ID) then begin case ReplaseParams of false: //16.01.2013 CurrList := GetJoinComponsIDs(ServerCompon.ID, WSCompon.ID, CurrLength, false); CurrList := GetJoinComponsIDs(ServerCompon, WSCompon, CurrLength, false); true: //16.01.2013 CurrList := GetJoinComponsIDs(WSCompon.ID, ServerCompon.ID, CurrLength, false); CurrList := GetJoinComponsIDs(WSCompon, ServerCompon, CurrLength, false); end; if CurrList <> nil then if (CurrLength <= LastLength) or (LastLength = 0) then begin //*** Присвоить краткий путь в результирующий список Lastlist.Clear; //ClearList(Lastlist); for k := 0 to CurrList.Count - 1 do begin //GetMem(ptrID, SizeOf(Integer)); //ptrID^ := Integer(CurrList.Items[k]^); LastList.Add(CurrList.Items[k]) end; LastLength := CurrLength; end; end; end; end; AResLength := LastLength; if LastList.Count = 0 then LastList.Free else Result := LastList; FreeAndNil(ComponentsFromServer); FreeAndNil(ComponentsFromWS); end; end; {with F_ProjMan.DM do begin ServerCatalog := TSCSCatalog.Create(F_ProjMan); WSCatalog := TSCSCatalog.Create(F_ProjMan); ServerCatalog.LoadCatalogByID(AIDCatalog1, true, false); WSCatalog.LoadCatalogByID(AIDCatalog2, true, false); //*** Проверить есть ли компоненты соед-е for i := 0 to ServerCatalog.SCSComponents.Count - 1 do begin ServerCompon := TSCSComponent(ServerCatalog.SCSComponents.Items[i]^); for j := 0 to WSCatalog.SCSComponents.Count - 1 do begin WSCompon := TSCSComponent(WSCatalog.SCSComponents.Items[j]^); CurrList := GetJoinComponsIDsAccountComplects(ServerCompon.ID, WSCompon.ID, CurrLength); if CurrList <> nil then if (CurrLength <= LastLength) or (LastLength = 0) then begin //*** Присвоить краткий путь в результирующий список ClearList(Lastlist); for k := 0 to CurrList.Count - 1 do begin New(ptrID); ptrID^ := Integer(CurrList.Items[k]^); LastList.Add(ptrID) end; LastLength := CurrLength; end; end; end; if LastList.Count = 0 then LastList.Free else Result := LastList; end; } finally //FreeAndNil(ServerCatalog); //FreeAndNil(WSCatalog); CurrList.Free; //FreeList(CurrList); end; except on E: Exception do AddExceptionToLog('GetComponentsJoiningCatalogs: '+E.Message); end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; (* //17.01.2013 - Не юзается // ##### Вернет список соединяющих линейных компонентов ##### ##### function GetAllTrace(AIDFigureServer, AIDFigureWS: Integer): TIntlist; var //ObjIDServer: Integer; //ObjIDWS: Integer; //ServerFigure: TSCSCatalog; //WSFigure: TSCSCatalog; //ServerCompon: TSCSComponent; //WSCompon: TSCSComponent; ComponIDList: TIntList; //IDComonStr: String; //IDSCSFigure: ^Integer; //i, j: Integer; //HaveTrace: Boolean; ResList: TIntlist; //SCSObject: TCatalog; TraceLength: Double; begin Result := nil; try ResList := nil; //HaveTrace := false; ComponIDList := nil; with F_ProjMan.DM do begin //ObjIDServer := GetIDCatalogByIDFigure(AIDFigureServer); //ObjIDWS := GetIDCatalogByIDFigure(AIDFigureWS); {ServerFigure := TSCSCatalog.Create(F_ProjMan); WSFigure := TSCSCatalog.Create(F_ProjMan); ServerFigure.LoadCatalogByID(ObjIDServer, true, false); WSFigure.LoadCatalogByID(ObjIDWS, true, false); //*** Проверить есть ли компоненты соед-е две Фигуры (СКС объекты) for i := 0 to ServerFigure.SCSComponents.Count - 1 do begin ServerCompon := TSCSComponent(ServerFigure.SCSComponents.Items[i]^); for j := 0 to WSFigure.SCSComponents.Count - 1 do begin WSCompon := TSCSComponent(WSFigure.SCSComponents.Items[j]^); ComponIDList := GetJoinComponsIDsAccountComplects(ServerCompon.ID, WSCompon.ID); if ComponIDList <> nil then begin HaveTrace := true; Break; end; end; if HaveTrace then Break; end; ServerFigure.Destroy; WSFigure.Destroy; } ComponIDList := nil; ComponIDList := GetComponentsJoiningCatalogs(AIDFigureServer, AIDFigureWS, TraceLength); if ComponIDList <> nil then ResList := GetTraceByListCompon(ComponIDList); Result := ResList; //*** Если фигуры соединены, то строим список ID-в трас(фигур) кот-е соединяют Сервер и Раб. станцию //if ComponIDList <> nil {HaveTrace} then // begin // ResList := Tlist.Create; // for i := 0 to ComponIDList.Count - 1 do // begin // SCSObject := GetCatalogByCompon(Integer(ComponIDList.Items[i]^)); // //IDComonStr := IntToStr(Integer(ComponIDList.Items[i]^)); // //SetSQLToQuery(scsQSelect, ' select id_item_type, scs_id from katalog '+ // // ' where id in (select id_catalog from catalog_relation '+ // // ' where id_component = '''+IDComonStr+''' ) '); // //if scsQSelect.FN('id_item_type').AsInteger = itSCSLine then // if SCSObject.ItemType = itSCSLine then // begin // New(IDSCSFigure); // IDSCSFigure^ := SCSObject.Scs_ID; // ResList.Add(IDSCSFigure); // end; // end; // end; end; {if ResList <> nil then begin if ResList.Count > 0 then Result := ResList else ResList.Free; end;} except ShowMessage('U_BaseCommon: GetAllTrace'); end; end; *) function GetAllTraceWithProperties(AIDFigureServer, AIDFigureWS: Integer): TTraceWithProperties; var //ObjIDServer: Integer; //ObjIDWS: Integer; //i: Integer; ComponIDList: TIntList; TraceList: TIntList; //IDCatalog: Integer; //strTraceLength: String; TraceLength: Double; begin //Tolik 13/06/2018 -- TraceList := nil; // try try Result.Trace := nil; Result.Length := 0; Screen.Cursor := crHourGlass; //TraceList := nil; //Tolik 13/06/2018 -- ComponIDList := nil; TraceLength := 0; GDragPrevTickCount := GetTickCount; with F_ProjMan do begin //ObjIDServer := DM.GetIDCatalogByIDFigure(AIDFigureServer); //ObjIDWS := DM.GetIDCatalogByIDFigure(AIDFigureWS); ComponIDList := nil; ComponIDList := GetComponentsJoiningCatalogs(AIDFigureServer, AIDFigureWS, TraceLength); if ComponIDList <> nil then begin TraceList := GetTraceByListCompon(ComponIDList); if TraceList <> nil then begin Result.Trace := IntListToList(TraceList); Result.Length := TraceLength; end; ComponIDList.Free; end; end; GDragCurrTickCount := GetTickCount - GDragPrevTickCount; GDragCurrTickCount := GetTickCount - GDragPrevTickCount; except on E: Exception do AddExceptionToLog('GetAllTraceWithProperties: '+E.Message); end; finally Screen.Cursor := crDefault; end; //Tolik 13/06/2018 -- if TraceList <> nil then TraceList.Free; // end; function GetConnectedTracesToConFigure(AIDConFigure: Integer): TList; var ObjList: TList; ObjID: Integer; PointObject: TSCSCatalog; PointComponent: TSCSComponent; LineComponents: TSCSComponents; CurrLineComponents: TSCSComponents; LineObject: TSCSCatalog; ptrID: ^Integer; i: Integer; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // begin Result := nil; OldTick := GetTickCount; try ObjList := nil; PointObject := nil; PointObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDConFigure); if Assigned(PointObject) then begin LineComponents := TSCSComponents.Create(false); for i := 0 to PointObject.ComponentReferences.Count - 1 do begin PointComponent := PointObject.ComponentReferences[i]; if Assigned(PointComponent) then begin CurrLineComponents := TSCSComponents(GetJoinedAllLinesToPointCompon(PointComponent.ID, PointComponent)); if Assigned(CurrLineComponents) then begin LineComponents.Assign(CurrLineComponents, laOr); FreeAndNil(CurrLineComponents); end; end; end; Result := TList.Create; for i := 0 to LineComponents.Count - 1 do begin LineObject := LineComponents[i].GetFirstParentCatalog; if Assigned(LineObject) then begin GetMem(ptrID, SizeOf(Integer)); ptrID^ := LineObject.SCSID; Result.Add(ptrID); end; end; FreeAndNil(LineComponents); end; with F_ProjMan.DM do begin { ObjID := GetIDCatalogByIDFigure(AIDConFigure); ObjList := TList.Create; SetFilterToSQLMemTable(tSQL_ConnectedComponents, 'id_connect_object = '''+IntToStr(ObjID)+''''); tSQL_Component.First; while Not tSQL_ConnectedComponents.Eof do begin SetFilterToSQLMemTable(tSQL_Component, 'whole_Id = '''+IntToStr(tSQL_ConnectedComponents.FieldByName(fnComponWholeID).AsInteger)+''''); IntFieldToListFromSQLMemTable(ObjList, tSQL_Component, fnObjectID); tSQL_ConnectedComponents.Next; end; Result := GetTraceByListOjects(ObjList); FreeList(ObjList); } {SetSQLToQuery(scsQSelect, ' select object_id from component, connected_components '+ ' where (id_connect_object = '''+IntToStr(ObjID)+''') and '+ ' (whole_id = compon_whole_id) '); ObjList := TList.Create; try IntFieldToList(ObjList, scsQSelect, 'object_id'); Result := GetTraceByListOjects(ObjList); finally FreeList(ObjList); end;} end; except on E: Exception do AddExceptionToLog('GetConnectedTracesToConFigure: '+E.Message); end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; // ##### Вернет трассы, на которой находится линейный компонент ##### function GetComponLineTrace(AIDComponent: Integer): TIntList; var //ResList: TList; IDPathList: TIntList; //IDAutoTracingPropertyStr: String; //ptrIDCompon: ^Integer; WholeLineCompon: TWholeLineCompon; begin Result := nil; try IDPathList := nil; //IDPathList := TList.Create; //*** Найти ID свойства авторокладки {with F_NormBase.DM do begin SetSQLToQuery(scsQSelect, ' select id from properties where sysname = ''AUTOTRACING'' '); IDAutoTracingPropertyStr := IntToStr(scsQSelect.FN('id').AsInteger); end; } //Step(AIDComponent, nil, 0); WholeLineCompon := GetLineComponsInTrace(AIDComponent, nil); //WholeLineCompon := GetLineComponsInTraceFromBase(AIDComponent); IDPathList := WholeLineCompon.WholeCompon; try //IDPathList := GetLineComponsInTraceFromBase(AIDComponent); if IDPathList <> nil then Result := GetTraceByListCompon(IDPathList); finally IDPathList.Free; //FreeList(IDPathList); WholeLineCompon.WholeComponObj.Free; end; except on E: Exception do AddExceptionToLog('GetComponLineTrace: '+E.Message); end; end; function GetCablesCountFromTrace(AFigureID, ASide, AIDNBCable: Integer): Integer; var GuidNBCable: String; TraceObject: TSCSCatalog; i, j: Integer; CableComponent: TSCSComponent; Interf: TSCSInterface; HaveComponentBusyInterfaces: Boolean; begin Result := 0; TraceObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AFigureID); if TraceObject <> nil then begin //GuidNBCable := F_NormBase.DM.GetStringFromTableByID(tnComponent, fnGuid, AIDNBCable, qmPhisical); for i := 0 to TraceObject.ComponentReferences.Count - 1 do begin CableComponent := TraceObject.ComponentReferences[i]; if CheckSysNameIsCable(CableComponent.ComponentType.SysName) then begin HaveComponentBusyInterfaces := false; for j := 0 to CableComponent.Interfaces.Count - 1 do begin Interf := CableComponent.Interfaces[j]; if (Interf.TypeI = itFunctional) and (Interf.Side = ASide) and (Interf.IsBusy = biTrue) then begin HaveComponentBusyInterfaces := true; Break; ///// BREAK ///// end; end; if Not HaveComponentBusyInterfaces then Result := Result + 1; end; end; end; end; procedure FreeTrace(ATraceList: TList); var i: Integer; begin for i := 0 to ATraceList.Count - 1 do TSCSComponent(ATraceList.Items[i]).Free; ATraceList.Clear; FreeAndNil(ATraceList); end; // ##### Вернет интерфейсы обоих сторон линейного объекта ##### function GetLineInterfacesFromPM(AIDFigure: Integer): TInterfLists; var InterfList1: Tlist; InterfList2: Tlist; InterfLists: TInterfLists; IDInterf: ^Integer; IDObj: Integer; begin Result.InterfList1 := nil; Result.InterfList2 := nil; { try InterfLists.InterfList1 := nil; InterfLists.InterfList2 := nil; Result := InterfLists; with F_ProjMan.DM do begin IDObj := GetIDCatalogByIDFigure(AIDFigure); if IDObj > 0 then begin InterfList1 := Tlist.Create; InterfList2 := Tlist.Create; SetSQLToQuery(scsQSelect, ' select id from interface_relation '+ ' where id_component in (select id_component from catalog_relation '+ ' where id_catalog = '''+IntToStr(IDObj)+''') '+ ' order by id_component, id_interface, id '); while Not scsQSelect.Eof do begin New(IDInterf); IDInterf^ := scsQSelect.FN('id').AsInteger; InterfList1.Add(IDInterf); scsQSelect.Next; New(IDInterf); IDInterf^ := scsQSelect.FN('id').AsInteger; InterfList2.Add(IDInterf); scsQSelect.Next; end; end; end; if InterfList1.Count > 0 then InterfLists.InterfList1 := InterfList1; if InterfList2.Count > 0 then InterfLists.InterfList2 := InterfList2; Result := InterfLists; except ShowMessage('EXCEPTION: GetLineInterfacesFromPM'); end; } end; // ##### Вернет интерфейсы не линейного объекта ##### function GetNoLineInterfacesFromPM(AIDFigure: Integer): TList; var InterfList: Tlist; IDInterf: ^Integer; ObjID: Integer; begin Result := nil; {try InterfList := nil; Result := InterfList; with F_ProjMan.DM do begin InterfList := Tlist.Create; ObjID := GetIDCatalogByIDFigure(AIDFigure); if ObjID > 0 then begin SetSQLToQuery(scsQSelect, ' select id from interface_relation '+ ' where id_component in (select id_component from catalog_relation '+ ' where id_catalog = '''+IntToStr(ObjID)+''') '+ ' order by id_component, id_interface, id '); while Not scsQSelect.Eof do begin New(IDInterf); IDInterf^ := scsQSelect.FN('id').AsInteger; InterfList.Add(IDInterf); scsQSelect.Next; end; end; end; if InterfList.Count > 0 then Result := InterfList else FreeList(InterfList); except ShowMessage('EXCEPTION: GetNoLineInterfacesFromPM'); end; } end; function CanLineComponLieToTrace(ASCSComponent: TObject): Boolean; begin //Exit; //#Del Result := false; try if ASCSComponent is TSCSComponent then begin if TSCSComponent(ASCSComponent).ComponentType.SysName = ctsnCableChannel then Result := True; end; except on E: Exception do AddExceptionToLog('CanLineComponLieToTrace: '+E.Message); end; end; function HaveObjectComponentByType(AIDFigure: Integer; AComponType: String; AWithOutOtherType: Boolean; AIsTemplate: Integer): Boolean; var SCSObject: TSCSCatalog; SCSComponent: TSCSComponent; i: integer; FindedComponent: Boolean; FindedComponentWithOtherType: Boolean; begin Result := false; try SCSObject := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then begin FindedComponent := false; FindedComponentWithOtherType := false; for i := 0 to SCSObject.ComponentReferences.Count - 1 do begin SCSComponent := SCSObject.ComponentReferences[i]; if (AIsTemplate = biNone) or (SCSComponent.IsTemplate = AIsTemplate) then begin if SCSComponent.ComponentType.SysName = AComponType then begin FindedComponent := true; if Not AWithOutOtherType then Break; //// BREAK //// end else begin FindedComponentWithOtherType := true; if AWithOutOtherType then Break; //// BREAK //// end; end; end; if FindedComponent and ((Not AWithOutOtherType) or (Not FindedComponentWithOtherType)) then Result := true; {SCSComponent := SCSObject.ComponentReferences.GetComponentByType(AComponType); if Assigned(SCSComponent) then Result := true;} end; except on E: Exception do AddExceptionToLog('HaveObjectComponentByType: '+E.Message); end; end; function HaveObjectComponentByTypes(AIDFigure: Integer; AComponTypes: TStringList; AWithOutOtherType: Boolean): Boolean; var SCSObject: TSCSCatalog; SCSComponent: TSCSComponent; i: integer; FindedComponent: Boolean; FindedComponentWithOtherType: Boolean; ParentCompon: TSCSComponent; ParentHaveCompType: Boolean; begin Result := false; try SCSObject := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then begin FindedComponent := false; FindedComponentWithOtherType := false; for i := 0 to SCSObject.ComponentReferences.Count - 1 do begin SCSComponent := SCSObject.ComponentReferences[i]; if AComponTypes.IndexOf(SCSComponent.ComponentType.SysName) <> -1 then begin FindedComponent := true; if Not AWithOutOtherType then Break; //// BREAK //// end else begin // Имеет ли компонент выше такой тип ParentHaveCompType := false; ParentCompon := SCSComponent; while ParentCompon <> nil do begin if AComponTypes.IndexOf(ParentCompon.ComponentType.SysName) <> -1 then begin ParentHaveCompType := true; Break; //// BREAK //// end; ParentCompon := ParentCompon.GetParentComponent; end; if Not ParentHaveCompType then begin FindedComponentWithOtherType := true; if AWithOutOtherType then Break; //// BREAK //// end; end; end; if FindedComponent and ((Not AWithOutOtherType) or (Not FindedComponentWithOtherType)) then Result := true; end; except on E: Exception do AddExceptionToLog('HaveObjectComponentByTypes: '+E.Message); end; end; function HaveObjectCorkComponent(AIDFigure: Integer): Boolean; var ComponTypeSysNames: TStringList; begin //Result := HaveObjectComponentByType(AIDFigure, ctsnCableChannelElement, true); Result := false; ComponTypeSysNames := TStringList.Create; ComponTypeSysNames.Add(ctsnCableChannelElement); ComponTypeSysNames.Add(ctsnTerminalBox); Result := HaveObjectComponentByTypes(AIDFigure, ComponTypeSysNames, true); FreeAndNil(ComponTypeSysNames); end; function HaveObjectCupboardComponent(AIDFigure: Integer): Boolean; //var SCSObject: TSCSCatalog; // SCSComponent: TSCSComponent; begin Result := HaveObjectComponentByType(AIDFigure, ctsnCupboard, false, biFalse); { Result := false; SCSObject := nil; SCSComponent := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then begin SCSComponent := SCSObject.ComponentReferences.GetComponentByType(ctCupboard); if Assigned(SCSComponent) then Result := true; end;} end; function HaveObjectSocketComponent(AIDFigure: Integer): Boolean; begin Result := HaveObjectComponentByType(AIDFigure, ctsnSocket, false, biNone); //Tolik 08/02/2022 -- это чтобы выравнивалось к левому краю графическое обозначение не только розетки, // но и рабочего места (Игорь попросил). if not Result then Result := HaveObjectComponentByType(AIDFigure, ctsnWorkPlace, false, biNone); end; function CheckCanJoinNBComponWithPointObjects(ANBComponent: TObject; AEndPointFigure, AFigureSnap: TObject): Boolean; var EndPointFigure: TObject; FigureSnap: TObject; NBComponent: TSCSComponent; CanJoinWithEnpPointFigure: Boolean; CanJoinWithFigureSnap: Boolean; EndPointFigureID: Integer; EnpPointFigureName: String; FigureSnapID: integer; FigureSnapName: String; FigureName: String; SCSObject: TSCSCatalog; StrMessage: String; begin Result := true; CanJoinWithEnpPointFigure := true; CanJoinWithFigureSnap := true; StrMessage := ''; EndPointFigureID := 0; EnpPointFigureName := ''; FigureSnapID := 0; FigureSnapName := ''; FigureName := ''; EndPointFigure := AEndPointFigure; FigureSnap := AFigureSnap; if EndPointFigure is TConnectorObject then //31.01.2011 if TConnectorObject(EndPointFigure).ConnectorType = ct_Clear then if TConnectorObject(EndPointFigure).FHouse <> nil then if TConnectorObject(EndPointFigure).FHouse is THouse then EndPointFigure := TConnectorObject(EndPointFigure).FHouse; if FigureSnap is TConnectorObject then //31.01.2011 if TConnectorObject(FigureSnap).ConnectorType = ct_Clear then if TConnectorObject(FigureSnap).FHouse <> nil then if TConnectorObject(FigureSnap).FHouse is THouse then FigureSnap := TConnectorObject(FigureSnap).FHouse; if EndPointFigure is TConnectorObject then begin if TConnectorObject(EndPointFigure).ConnectorType <> ct_Clear then begin EndPointFigureID := TConnectorObject(EndPointFigure).ID; EnpPointFigureName := TConnectorObject(EndPointFigure).Name + IntToStr(TConnectorObject(EndPointFigure).FIndex); end; end else if EndPointFigure is THouse then begin EndPointFigureID := THouse(EndPointFigure).ID; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(EndPointFigureID); if SCSObject <> nil then EnpPointFigureName := SCSObject.GetNameForVisible; end; if FigureSnap is TConnectorObject then begin if TConnectorObject(FigureSnap).ConnectorType <> ct_Clear then begin FigureSnapID := TConnectorObject(FigureSnap).ID; FigureSnapName := TConnectorObject(FigureSnap).Name + IntToStr(TConnectorObject(FigureSnap).FIndex); end; end else if FigureSnap is THouse then begin FigureSnapID := THouse(FigureSnap).ID; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(FigureSnapID); if SCSObject <> nil then EnpPointFigureName := SCSObject.GetNameForVisible; end; NBComponent := TSCSComponent(ANBComponent); //30.01.2009 //EnpPointFigureName := AEndPointFigure.Name + IntToStr(AEndPointFigure.FIndex); //FigureSnapName := AFigureSnap.Name + IntToStr(AFigureSnap.FIndex); //if (AEndPointFigure.ConnectorType <> ct_Clear) and (AFigureSnap.ConnectorType <> ct_Clear) then // begin // CanJoinWithFigureSnap := CanConnectLineComponWithConObjects(NBComponent.ID, AFigureSnap.ID, AEndPointFigure.ID); // CanJoinWithEnpPointFigure := CanJoinWithFigureSnap; // end // else // begin // if AEndPointFigure.ConnectorType <> ct_Clear then // CanJoinWithEnpPointFigure := CanConnectLineComponWithConObjects(NBComponent.ID, AEndPointFigure.ID, -1); // if AFigureSnap.ConnectorType <> ct_Clear then // CanJoinWithFigureSnap := CanConnectLineComponWithConObjects(NBComponent.ID, AFigureSnap.ID, -1); // end; if (EndPointFigureID <> 0) and (FigureSnapID <> 0) then begin CanJoinWithFigureSnap := CanConnectLineComponWithConObjects(NBComponent.ID, FigureSnapID, EndPointFigureID); CanJoinWithEnpPointFigure := CanJoinWithFigureSnap; end else begin if EndPointFigureID <> 0 then CanJoinWithEnpPointFigure := CanConnectLineComponWithConObjects(NBComponent.ID, EndPointFigureID, -1); if FigureSnapID <> 0 then CanJoinWithFigureSnap := CanConnectLineComponWithConObjects(NBComponent.ID, FigureSnapID, -1); end; if Not CanJoinWithEnpPointFigure and Not CanJoinWithFigureSnap then StrMessage := cImpossibleConnectTracingCompon+' "'+NBComponent.GetNameForVisible+'"'+ ' '+cToObjectsComponents+' "'+EnpPointFigureName+'" и "'+FigureSnapName+'".' else if Not CanJoinWithEnpPointFigure or Not CanJoinWithFigureSnap then begin if Not CanJoinWithEnpPointFigure then FigureName := EnpPointFigureName; if Not CanJoinWithFigureSnap then FigureName := FigureSnapName; if FigureName <> '' then StrMessage := cImpossibleConnectTracingCompon+' "'+NBComponent.GetNameForVisible+'" '+cToObjectComponents+' "'+FigureName+'".'; end; if StrMessage <> '' then begin PauseProgress(true); try if MessageModal(StrMessage+#13+#10+cCanTracing+' '+NBComponent.GetNameForVisible+'?', ApplicationName, MB_ICONQUESTION or MB_YESNO) <> IDYES then Result := false; finally PauseProgress(false); end; end; end; function CanConnectLineComponWithConObjects(AIDNBLineCompon, AIDPointFigure, AIDFinalFigure: Integer; aConsiderBoxAndRack: Boolean=false): Boolean; begin Result := F_ProjMan.F_ChoiceConnectSide.CanConnectLineComponWithConObjects(AIDNBLineCompon, AIDPointFigure, AIDFinalFigure, aConsiderBoxAndRack); end; function ConnectObjectsInPM(AConnectObjectParams1, AConnectObjectParams2: Tlist): Boolean; begin Result := false; //*** Если идет разделение линии то эту функцию не юзать if GLockConnectDisconnectCount > 0 then Exit; //#Del try if (AConnectObjectParams1 = nil) or (AConnectObjectParams2 = nil) then Exit; //// Exit ///// Result := F_ProjMan.F_ChoiceConnectSide.ConnectObjects(AConnectObjectParams1, AConnectObjectParams2); except on E: Exception do AddExceptionToLog('ConnectObjectsInPM: '+E.Message); end; end; function ConnectObjectsInPMByWay(AWay: TIntList; AFigures, ASCSObjs: TList; APosList: TIntList = nil; aConsiderBoxAndRack: Boolean=false): Boolean; begin //Exit; //#Del Result := false; try if AWay = nil then Exit; ///// EXIT //// Result := F_ProjMan.F_ChoiceConnectSide.ConnectObjectsByWay(AWay, AFigures, ASCSObjs, APosList, aConsiderBoxAndRack); except on E: Exception do AddExceptionToLog('ConnectObjectsByWay: '+E.Message); end; end; function DisconnectObjectsInPM(AIDObjectList1, AIDObjectList2: Tlist): Boolean; begin Result := false; //*** Если идет разделение линии то эту функцию не юзать if GLockConnectDisconnectCount > 0 then Exit; //#Del try Result := F_ProjMan.F_ChoiceConnectSide.DisconnectObjects(AIDObjectList1, AIDObjectList2); except On E: Exception do AddExceptionToLog('DisconnectObjectsInPM: '+E.Message); end; end; //##### Вернет список объектов кот. м.б конечными в таком порядке: сначала шкафы в порядке убывания интерфейсов ##### // затем остальные в порядке убывания интерфейсов //Tolik 25/09/2021 -- старая закомменчена - см. ниже. Здесь выполнена фильтрация на соответствие типу сети, // если в Нормативке выбран кабель и дропается на КАД function GetEndPointParamsFromList(AIDList: Integer; AOnlyCupBoard: Boolean): TList; var SCSList: TSCSList; SCSCatalog: TSCScatalog; FirstComponent: TSCSComponent; PointObjects: TSCSCatalogs; PointObject: TSCSCatalog; PointObjectFirstComponent: TSCSComponent; PointObjectInterfCounts: TintList; FromIndex: Integer; ToIndex: Integer; IndexToInsert: Integer; NoCupBoardIndex: Integer; CurrInterfCount: Integer; ptrObjectParams: PObjectParams; i, j: Integer; CableSelected: Boolean; function CheckCatalogByNetType: Boolean; var i: integer; begin Result := False; if GDropComponent.isTemplate = biFalse then begin for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[i].IDNetType = GDropComponent.IDNetType then begin Result := True; break; end; end; end else begin for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[i].IDNetType = 1 then begin Result := True; break; end; end; end; end; function CheckChildComponBySysName(aCompon: TSCSComponent): Boolean; begin Result := False; if ((GDropComponent <> nil) and (isCableComponent(GDropComponent))) then begin if (GDropComponent.IDNetType = 3) then Result := (aCompon.ComponentType.SysName = ctsnSHIELD) else Result := ((aCompon.ComponentType.SysName = ctsnCupBoard) or (aCompon.ComponentType.SysName = ctsnBox)); end else begin Result := ((aCompon.ComponentType.SysName = ctsnCupBoard) or (aCompon.ComponentType.SysName = ctsnBox) or (aCompon.ComponentType.SysName = ctsnSHIELD)); end; end; function CheckCatalogBySnap: Boolean; var Figure: TFigure; Cad: TF_CAD; i: Integer; begin Result := True; if GFigureSnap <> nil then begin Cad := GetListByID(SCSList.ListID); if Cad <> nil then begin Figure := GetFigureById(Cad, SCSCatalog.SCSID); if Figure <> nil then begin if GFigureSnap.Id = Figure.Id then Result := False; end; end; end; end; function CheckNoRaise(ACatalog: TSCSCatalog): boolean; var fig: TFigure; JoinedConn, RaiseConn: TConnectorObject; JoinedLine: TOrthoLine; cad: TF_Cad; i, j: integer; begin Result := false; cad := GetListByID(SCSList.SCSID); if cad <> nil then begin fig := GetFigureByID(cad, aCatalog.SCSID); if fig <> nil then begin if fig is TConnectorObject then begin if TConnectorObject(fig).ConnectorType = ct_NB then begin for i := 0 to TConnectorObject(fig).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(fig).JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FIsRaiseUpDown then begin end; end; end; end; end; end; end; end; begin Result := TList.Create; CableSelected := False; if GDropComponent <> nil then begin if isCableComponent(GDropComponent) then CableSelected := true; end; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then begin if SCSList.Setting.ListType = lt_Normal then // Tolik 04/10/2021 - - отфильтровать только нормальные листы begin PointObjects := TSCSCatalogs.Create(false); PointObjectInterfCounts := TIntList.Create; for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do begin SCSCatalog := SCSList.ChildCatalogReferences[i]; if CheckCatalogBySnap then begin if CableSelected then begin if (SCSCatalog.ItemType = itSCSConnector) and (SCSCatalog.SCSComponents.Count > 0) then begin if CheckCatalogByNetType then begin FirstComponent := SCSCatalog.GetFirstComponent; //*** Определить индекс - где заканчивается шкаф и нач-ся оюъекты других типов NoCupBoardIndex := -1; for j := 0 to PointObjects.Count - 1 do begin PointObject := PointObjects[j]; PointObjectFirstComponent := PointObject.GetFirstComponent; if PointObjectFirstComponent.ComponentType.SysName <> ctsnCupBoard then begin NoCupBoardIndex := j; Break; //// BREAK //// end; end; if NoCupBoardIndex = -1 then NoCupBoardIndex := PointObjects.Count; //*** определить начальный и конечный индексы, //которые будут выделять область для вставкии новой позиции оюъекта FromIndex := -1; ToIndex := -1; if CheckChildComponBySysName(FirstComponent) then begin FromIndex := 0; ToIndex := NoCupBoardIndex - 1; end else if Not AOnlyCupBoard then begin FromIndex := NoCupBoardIndex; ToIndex := PointObjects.Count - 1; end; if (FromIndex <> -1) then begin IndexToInsert := -1; CurrInterfCount := SCSCatalog.GetInterfaceCount([itFunctional], biFalse); for j := FromIndex to ToIndex do if CurrInterfCount > PointObjectInterfCounts[j] then begin IndexToInsert := j; Break; //// BREAK //// end; if IndexToInsert = -1 then IndexToInsert := ToIndex + 1; if IndexToInsert <> -1 then begin PointObjects.Insert(IndexToInsert, SCSCatalog); PointObjectInterfCounts.Insert(IndexToInsert, CurrInterfCount); end; end; end; end; end else begin if (SCSCatalog.ItemType = itSCSConnector) and (SCSCatalog.SCSComponents.Count > 0) then begin FirstComponent := SCSCatalog.GetFirstComponent; //*** Определить индекс - где заканчивается шкаф и нач-ся оюъекты других типов NoCupBoardIndex := -1; for j := 0 to PointObjects.Count - 1 do begin PointObject := PointObjects[j]; PointObjectFirstComponent := PointObject.GetFirstComponent; if PointObjectFirstComponent.ComponentType.SysName <> ctsnCupBoard then begin NoCupBoardIndex := j; Break; //// BREAK //// end; end; if NoCupBoardIndex = -1 then NoCupBoardIndex := PointObjects.Count; //*** определить начальный и конечный индексы, //которые будут выделять область для вставкии новой позиции оюъекта FromIndex := -1; ToIndex := -1; if (FirstComponent.ComponentType.SysName = ctsnCupBoard) or (FirstComponent.ComponentType.SysName = ctsnBox) then begin FromIndex := 0; ToIndex := NoCupBoardIndex - 1; {if NoCupBoardIndex = 0 then ToIndex := NoCupBoardIndex else if NoCupBoardIndex > 0 then ToIndex := NoCupBoardIndex - 1;} end else if Not AOnlyCupBoard then begin FromIndex := NoCupBoardIndex; ToIndex := PointObjects.Count - 1; {if PointObjects.Count = 0 then ToIndex := PointObjects.Count else ToIndex := PointObjects.Count - 1;} end; if (FromIndex <> -1) then begin IndexToInsert := -1; CurrInterfCount := SCSCatalog.GetInterfaceCount([itFunctional], biFalse); for j := FromIndex to ToIndex do if CurrInterfCount > PointObjectInterfCounts[j] then begin IndexToInsert := j; Break; //// BREAK //// end; if IndexToInsert = -1 then IndexToInsert := ToIndex + 1; if IndexToInsert <> -1 then begin PointObjects.Insert(IndexToInsert, SCSCatalog); PointObjectInterfCounts.Insert(IndexToInsert, CurrInterfCount); end; end; end; end; end; end; end; for i := 0 to PointObjects.Count - 1 do begin PointObject := PointObjects[i]; GetMem(ptrObjectParams, SizeOf(TObjectParams)); ptrObjectParams^ := PointObject.GetObjectParams; Result.Add(ptrObjectParams); end; FreeAndNil(PointObjectInterfCounts); FreeAndNil(PointObjects); end; end; (* function GetEndPointParamsFromList(AIDList: Integer; AOnlyCupBoard: Boolean): TList; var SCSList: TSCSList; SCSCatalog: TSCScatalog; FirstComponent: TSCSComponent; PointObjects: TSCSCatalogs; PointObject: TSCSCatalog; PointObjectFirstComponent: TSCSComponent; PointObjectInterfCounts: TintList; FromIndex: Integer; ToIndex: Integer; IndexToInsert: Integer; NoCupBoardIndex: Integer; CurrInterfCount: Integer; ptrObjectParams: PObjectParams; i, j: Integer; begin Result := TList.Create; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then begin PointObjects := TSCSCatalogs.Create(false); PointObjectInterfCounts := TIntList.Create; for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do begin SCSCatalog := SCSList.ChildCatalogReferences[i]; if (SCSCatalog.ItemType = itSCSConnector) and (SCSCatalog.SCSComponents.Count > 0) then begin FirstComponent := SCSCatalog.GetFirstComponent; //*** Определить индекс - где заканчивается шкаф и нач-ся оюъекты других типов NoCupBoardIndex := -1; for j := 0 to PointObjects.Count - 1 do begin PointObject := PointObjects[j]; PointObjectFirstComponent := PointObject.GetFirstComponent; if PointObjectFirstComponent.ComponentType.SysName <> ctsnCupBoard then begin NoCupBoardIndex := j; Break; //// BREAK //// end; end; if NoCupBoardIndex = -1 then NoCupBoardIndex := PointObjects.Count; //*** определить начальный и конечный индексы, //которые будут выделять область для вставкии новой позиции оюъекта FromIndex := -1; ToIndex := -1; if (FirstComponent.ComponentType.SysName = ctsnCupBoard) or (FirstComponent.ComponentType.SysName = ctsnBox) then begin FromIndex := 0; ToIndex := NoCupBoardIndex - 1; {if NoCupBoardIndex = 0 then ToIndex := NoCupBoardIndex else if NoCupBoardIndex > 0 then ToIndex := NoCupBoardIndex - 1;} end else if Not AOnlyCupBoard then begin FromIndex := NoCupBoardIndex; ToIndex := PointObjects.Count - 1; {if PointObjects.Count = 0 then ToIndex := PointObjects.Count else ToIndex := PointObjects.Count - 1;} end; if (FromIndex <> -1) then begin IndexToInsert := -1; CurrInterfCount := SCSCatalog.GetInterfaceCount([itFunctional], biFalse); for j := FromIndex to ToIndex do if CurrInterfCount > PointObjectInterfCounts[j] then begin IndexToInsert := j; Break; //// BREAK //// end; if IndexToInsert = -1 then IndexToInsert := ToIndex + 1; if IndexToInsert <> -1 then begin PointObjects.Insert(IndexToInsert, SCSCatalog); PointObjectInterfCounts.Insert(IndexToInsert, CurrInterfCount); end; end; end; end; for i := 0 to PointObjects.Count - 1 do begin PointObject := PointObjects[i]; GetMem(ptrObjectParams, SizeOf(TObjectParams)); ptrObjectParams^ := PointObject.GetObjectParams; Result.Add(ptrObjectParams); end; FreeAndNil(PointObjectInterfCounts); FreeAndNil(PointObjects); end; end; *) // ##### освобождает интерфейсы ##### procedure FreeLineFigureInterfaces(AIDFigure, ASide: Integer); var i, j: integer; IDCatalog: Integer; IDInterf: Integer; InterfacesList: Tlist; ListConnection: TList; //*** Список соединений begin { try try InterfacesList := Tlist.Create; ListConnection := TList.Create; with F_ProjMan do begin //*** Загрузить интерфейсы для объекта IDCatalog := DM.GetIDCatalogByIDFigure(AIDFigure); SetSQLToQuery(DM.scsQSelect, ' select id from interface_Relation '+ ' where (side = '''+IntToStr(ASide)+''') and '+ ' (id_component in (select id_component from catalog_relation '+ ' where id_catalog = '''+IntToStr(IDCatalog)+''' )) '); DM.IntFieldToList(InterfacesList, DM.scsQSelect, 'id'); for i := 0 to InterfacesList.Count - 1 do begin IDInterf := Integer(InterfacesList.Items[i]^); //*** Выбрать соединения с участвием интерфейса IDInterf SetSQLToQuery(DM.scsQSelect, ' select id_comp_rel from interfofinterf_relation '+ ' where (id_interf_rel = '''+IntToStr(IDInterf)+''') or (id_interf_to = '''+IntToStr(IDInterf)+''') '); DM.IntFieldToList(ListConnection, DM.scsQSelect, 'id_comp_rel'); for j := 0 to ListConnection.Count - 1 do FreeCompRel(Integer(ListConnection.Items[j]^)); ClearList(ListConnection); end; RefreshNode; end; except on E: Exception do AddExceptionToLog('FreeLineFigureInterfaces: '+E.Message); end; finally FreeList(InterfacesList); FreeList(ListConnection); end; } end; function GetPairCountFromTrace(AListID, ATraceFigureID: Integer): string; var List: TSCSList; SCSTrace: TSCSCatalog; i: Integer; PairCount: integer; Pairs: TIntList; Kolvos: TIntList; KolvosIndex: Integer; Prefix: String; //SCSComponent: TSCSComponent; //SCSInterf: TSCSInterface; //ComponPairCount: Integer; //LookedNumPairs: TIntList; //i, j: Integer; begin Result := ''; PairCount := 0; List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if List <> nil then begin SCSTrace := List.GetCatalogFromReferencesBySCSID(ATraceFigureID); if SCSTrace <> nil then begin Pairs := TIntList.Create; Kolvos := TIntList.Create; Prefix := 'x'; if List.Setting.NoteCountPrefix <> '' then Prefix := List.Setting.NoteCountPrefix; for i := 0 to SCSTrace.ComponentReferences.Count - 1 do begin if SCSTrace.ComponentReferences[i].IsDismount = biFalse then begin PairCount := GetComponPairCount(SCSTrace.ComponentReferences[i]); KolvosIndex := Pairs.IndexOf(PairCount); if KolvosIndex = -1 then begin KolvosIndex := Pairs.Add(PairCount); Kolvos.Add(1); end else begin Kolvos[KolvosIndex] := Kolvos[KolvosIndex] + 1; end; end; end; for i := 0 to Pairs.Count - 1 do begin if i > 0 then Result := Result + '; '; Result := Result + GetPrefixCountByType(IntToStr(Pairs[i]), Prefix, Kolvos[i], List.Setting.PrefixCountType); //Result := Result + IntToStr(Pairs[i]); //if Kolvos[i] > 1 then // Result := Result + Prefix + IntToStr(Kolvos[i]); end; FreeAndNil(Pairs); FreeAndNil(Kolvos); {LookedNumPairs := TIntList.Create; for i := 0 to SCSTrace.ComponentReferences.Count - 1 do begin SCSComponent := SCSTrace.ComponentReferences[i]; ComponPairCount := 0; LookedNumPairs.Clear; for j := 0 to SCSComponent.Interfaces.Count - 1 do begin SCSInterf := SCSComponent.Interfaces[j]; if (SCSInterf.TypeI = itFunctional) and (LookedNumPairs.IndexOf(SCSInterf.NumPair) = -1) then begin Inc(ComponPairCount); LookedNumPairs.Add(SCSInterf.NumPair); end; end; Result := Result + ComponPairCount; end; LookedNumPairs.Free;} end; //Result := IntToStr(PairCount); end; end; function GetFigureInterfacesToConnect(AIDFigure: Integer): TList; var //IDListCatalog: Integer; Catalog: TSCSCatalog; //ObjectList: TList; //ptrObject: PSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; i, j, k: Integer; //IDList: TIntList; //ptrID: ^Integer; InterfList: TRapObjectList; //InterfID: Integer; SprInterf: TNBInterface; ResList: TList; ptrInterfListItemParams: PIDAndCaption; procedure AddInterfToIDList(AInterfID: Integer; ASprInterf:TNBInterface=nil); var SprInterf: TNBInterface; i: Integer; InterfsAccord: TSCSObjectList; begin //if IDList.IndexOf(AInterf.ID_Interface) = -1 then // IDList.Add(AInterf.ID_Interface); if InterfList.GetObject(AInterfID) = nil then begin SprInterf := ASprInterf; if SprInterf = nil then SprInterf := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByID(AInterfID); if SprInterf <> nil then begin InterfList.Insert(SprInterf, @SprInterf.ID); // Добавляем соответсвующие интерфейсы из AInterfID for i := 0 to SprInterf.InterfaceAccordance.Count - 1 do AddInterfToIDList(TNBInterfaceAccordance(SprInterf.InterfaceAccordance[i]).IDAccordance); // Добавляем нтерфейсы в которых AInterfID как соответствующий InterfsAccord := F_NormBase.GSCSBase.NBSpravochnik.GetInterfacesForAccordance(SprInterf); for i := 0 to InterfsAccord.Count - 1 do AddInterfToIDList(TNBInterface(InterfsAccord[i]).ID, TNBInterface(InterfsAccord[i])); InterfsAccord.Free; end; end; end; begin Result := nil; try ResList := TList.Create; //IDList := TIntList.Create; InterfList := TRapObjectList.Create; Catalog := nil; try with F_ProjMan do begin Catalog := nil; Catalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(Catalog) then for i := 0 to Catalog.ComponentReferences.Count - 1 do begin SCSComponent := Catalog.ComponentReferences.Items[i]; for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces.Items[j]; if Interfac.Kind = ikNoSplit then if Interfac.TypeI = itFunctional then AddInterfToIDList(Interfac.ID_Interface); end; end; end; with F_NormBase.DM do begin //05.02.2011 //ChangeSQLQuery(scsQSelect, ' select name from interface where id = :id '); //for i := 0 to IDList.Count - 1 do //begin // InterfID := IDList[i]; //Integer(IDList.Items[i]^); // scsQSelect.Close; // scsQSelect.SetParamAsInteger('id', InterfID); // scsQSelect.ExecQuery; // // //New(ptrInterfListItemParams); // GetMem(ptrInterfListItemParams, SizeOf(TIDAndCaption)); // ptrInterfListItemParams.Caption := scsQSelect.GetFNAsString('name'); // ptrInterfListItemParams.ID := InterfID; // ResList.Add(ptrInterfListItemParams); //end; end; //05.02.2011 for i := 0 to InterfList.Count - 1 do begin SprInterf := TNBInterface(InterfList[i]); GetMem(ptrInterfListItemParams, SizeOf(TIDAndCaption)); ptrInterfListItemParams.Caption := SprInterf.Name; ptrInterfListItemParams.ID := SprInterf.ID; ResList.Add(ptrInterfListItemParams); end; if ResList.Count = 0 then ResList.Free else Result := ResList; finally //IDList.Free; //FreeList(IDList); //FreeAndNil(Catalog); InterfList.Free; end; except on E: Exception do AddExceptionToLog('GetCurrListInterfaces: '+E.Message); end; end; // #### Вернет шобъектов в кот. имеются интерфейсы AInterfIDList #### function GetConnectorsByInterfaces(AInterfIDList: TList): TList; var IDListCatalog: Integer; //Catalog: TSCSCatalog; ObjectList: TList; SCSObject: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; i, j, k: Integer; IDList: TList; ptrID: ^Integer; InterfID: Integer; WasBreak: Boolean; //ResList: TList; begin Result := nil; try if AInterfIDList = nil then Exit; ///// EXIT //// Result := TList.Create; with F_ProjMan do begin for i := 0 to GSCSBase.CurrProject.CurrList.ChildCatalogReferences.Count - 1 do begin SCSObject := GSCSBase.CurrProject.CurrList.ChildCatalogReferences[i]; if Assigned(SCSObject) then if SCSObject.ItemType = itSCSConnector then begin WasBreak := false; for j := 0 to SCSObject.ComponentReferences.Count - 1 do begin SCSComponent := SCSObject.ComponentReferences[j]; if Assigned(SCSComponent) then for k := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces.Items[k]; if Interfac.TypeI = itFunctional then if Not CheckNoIDinList(Interfac.ID_Interface, AInterfIDList) then if CheckNoIDinList(SCSObject.SCSID, Result) then begin GetMem(ptrID, SizeOf(Integer)); ptrID^ := SCSObject.SCSID; Result.Add(ptrID); WasBreak := true; Break; end; if WasBreak then Break; end; if WasBreak then Break; end; end; end; end; except on E: Exception do AddExceptionToLog('GetConnectorsByInterfaces: '+E.Message); end; (* try if AInterfIDList = nil then Exit; ///// EXIT //// ResList := TList.Create; IDList := Tlist.Create; with F_ProjMan.DM do begin IDListCatalog := GetIDCatalogByIDList(GIDLastList); SetSQLToQuery(scsQSelect, ' select id from katalog '+ ' where (parent_id = '''+IntTostr(IDListCatalog)+''') and (id_item_type = '''+IntToStr(itSCSConnector)+''') '); ObjectList := TList.Create; try while Not scsQSelect.Eof do begin SCSObject := TSCSCatalog.Create(TForm(F_ProjMan)); SCSObject.ID := scsQSelect.GetFNAsInteger('id'); ObjectList.Add(SCSObject); scsQSelect.Next; end; for i := 0 to ObjectList.Count - 1 {Catalog.ChildCatalogs.Count} do begin SCSObject := ObjectList.Items[i]; //Catalog.ChildCatalogs.Items[i]; SCSObject.LoadCatalogByID(SCSObject.ID, false); WasBreak := false; if SCSObject.ItemType = itSCSConnector then begin SCSObject.LoadAllComponents(SCSObject.ID, false); for j := 0 to SCSObject.SCSComponents.Count - 1 do begin SCSComponent := SCSObject.SCSComponents.Items[j]; SCSComponent.LoadInterfaces(-1, false); for k := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces.Items[k]; if Interfac.TypeI = itFunctional then if Not CheckNoIDinList(Interfac.ID_Interface, AInterfIDList) then if CheckNoIDinList(SCSObject.SCSID, ResList) then begin //New(ptrID); GetMem(ptrID, SizeOf(Integer)); ptrID^ := SCSObject.SCSID; ResList.Add(ptrID); WasBreak := true; Break; end; if WasBreak then Break; end; if WasBreak then Break; end; end; end; finally FreeList(IDList); for i := 0 to ObjectList.Count - 1 do begin SCSObject := ObjectList.Items[i]; FreeAndNil(SCSObject); end; //catalog.Free; end; end; if ResList.Count = 0 then FreeAndNil(ResList) else Result := ResList; except on E: Exception do AddExceptionToLog('GetConnectorsByInterfaces: '+E.Message); end;*) end; function GetCopyConnectObjectParams(AConnectObjectParams: TList): TList; var ptrObjectParam: PConnectObjectParam; ptrNewObjectParam: PConnectObjectParam; i: integer; begin Result := TList.Create; for i := 0 to AConnectObjectParams.Count - 1 do begin ptrObjectParam := AConnectObjectParams[i]; GetZeroMem(ptrNewObjectParam, SizeOf(TConnectObjectParam)); ptrNewObjectParam^ := ptrObjectParam^; Result.Add(ptrNewObjectParam); end; end; function GetCadDataFromPM(AIDList: Integer; var AFileName: String): TMemoryStream; var SCSList: TSCSList; begin Result := nil; try SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if Assigned(SCSList) then begin //Result := SCSList.GetCADStream; AFileName := SCSList.ListCADFile; end; except on E: Exception do AddExceptionToLog('GetCadDataFromPM: '+E.Message); end; end; function GetCadFileNameForSaveToPM(AIDList: Integer): string; var SCSList: TSCSList; begin Result := ''; try SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if Assigned(SCSList) then begin SCSList.DeleteCADFile; Result := SCSList.ListCADFile; end; except on E: Exception do AddExceptionToLog('GetCadFileNameForSaveToPM: '+E.Message); end; end; // ##### Вернет длину между 2-мя точ-ми объектами ##### function GetLengthBetweenFigures(AIDFigure1, AIDFigure2: Integer): Double; var ObjIDFigure1: Integer; ObjIDFigure2: Integer; JoinedComponents: TList; strComponLength: String; ComponLength: Double; SummarLength: Double; i: Integer; begin Result := 0; {try try Result := 0; JoinedComponents := nil; SummarLength := 0; with F_ProjMan do begin ObjIDFigure1 := DM.GetIDCatalogByIDFigure(AIDFigure1); ObjIDFigure2 := DM.GetIDCatalogByIDFigure(AIDFigure2); JoinedComponents := GetComponentsJoiningCatalogs(ObjIDFigure1, ObjIDFigure2); if JoinedComponents <> nil then for i := 0 to JoinedComponents.Count - 1 do begin strComponLength := GetPropertyValue(tkComponent, Integer(JoinedComponents.Items[i]^), 'LENGTH'); if strComponLength <> '' then begin ComponLength := StrToFloat_My(strComponLength); SummarLength := SummarLength + ComponLength; end; end; end; Result := SummarLength; except on E: Exception do AddExceptionToLog('GetLengthBetweenFigures: '+E.Message); end; finally FreeList(JoinedComponents); end; } end; function SetCadDataToPM(AIDList: Integer; AStream: TMemoryStream): Boolean; var //RecExists: Boolean; //IDCatalog: Integer; //IDCadData: Integer; SCSList: TSCSList; begin Result := false; try //IDCadData := -1; //RecExists := false; if (AStream <> nil) and (AIDList > 0) then with F_ProjMan do begin SCSList := GSCSBase.CurrProject.GetListBySCSID(AIDList); if Assigned(SCSList) then if Not SCSList.IsDeleting then SCSList.SetCADStream(AStream); end; {with F_ProjMan.DM do begin IDCatalog := GetIDCatalogByIDList(AIDList); if SetFilterToSQLMemTable(tSQL_Katalog, 'id = '''+IntToStr(IDCatalog)+'''') then begin AStream.Position := 0; tSQL_Katalog.Edit; TBlobField(tSQL_Katalog.FieldByName(fnCADBlock)).LoadFromStream(AStream); tSQL_Katalog.Post; Result := true; end; end; } except on E: Exception do AddExceptionToLog('SetCadDataToPM: '+E.Message); end; end; function ListToDeleting(AIDList: Integer): Boolean; var SCSList: TSCSList; begin Result := false; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then begin if SCSList.IsDeleting then Result := true else if F_ProjMan.GSCSBase.CurrProject.ReadOnly then Result := true; end; end; // ##### Устанавливает интерфейсам Z координату в МП ##### procedure SetLineFigureCoordZInPM(AIDFigure, ASide: Integer; ACoordZ: Double); var i, j: Integer; IDCatalog: Integer; FigureNode: TTreeNode; FigureDat: PObjectData; SCSTrace: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; PropertyName: String; begin //Exit; //#Del try if (ASide < 1) or (ASide > 2) then Exit; ///// EXIT ///// PropertyName := ''; case ASide of 1: PropertyName := pnHeightSide1; 2: PropertyName := pnHeightSide2; end; FigureNode := nil; with F_ProjMan do begin SCSTrace := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSTrace) then begin F_ChoiceConnectSide.DefineTraceStyleInCAD(SCSTrace); for i := 0 to SCSTrace.ComponentReferences.Count - 1 do if Assigned(SCSTrace.ComponentReferences[i]) then begin SCSTrace.ComponentReferences[i].SetPropertyValueAsFloat(PropertyName, ACoordZ, true); //DM.SetPropertyValueAsFloat(tkComponent, SCSTrace.ComponentReferences[i].ID, PropertyName, ACoordZ, qmMemory, -1); end; { for j := 0 to SCSTrace.ComponentReferences[i].Interfaces.Count - 1 do begin Interfac := SCSTrace.ComponentReferences[i].Interfaces[j]; if Interfac.Side = ASide then begin Interfac.CoordZ := ACoordZ; SetFilterToSQLMemTable(DM.tSQL_InterfaceRelation, 'id = '''+IntToStr(Interfac.ID)+''''); if Not DM.tSQL_InterfaceRelation.Eof then begin DM.tSQL_InterfaceRelation.Edit; DM.tSQL_InterfaceRelation.FieldByName(fnCoordZ).AsFloat := ACoordZ; DM.tSQL_InterfaceRelation.Post; end; end; end; {IDCatalog := DM.GetIDCatalogByIDFigure(AIDFigure); SetFilterToSQLMemTable(DM.tSQL_CatalogRelation, 'id_catalog = '''+IntTostr(IDCatalog)+''''); DM.tSQL_CatalogRelation.First; while Not DM.tSQL_CatalogRelation.Eof do begin SetFilterToSQLMemTable(DM.tSQL_InterfaceRelation, 'id_component = '''+IntTostr(DM.tSQL_CatalogRelation.FieldByName(fnIDComponent).AsInteger)+''''); DM.tSQL_InterfaceRelation.First; while Not DM.tSQL_InterfaceRelation.Eof do begin if DM.tSQL_InterfaceRelation.FieldByName(fnSide).AsInteger = ASide then begin DM.tSQL_InterfaceRelation.Edit; DM.tSQL_InterfaceRelation.FieldByName(fnCoordZ).AsFloat := ACoordZ; DM.tSQL_InterfaceRelation.Post; end; DM.tSQL_InterfaceRelation.Next; end; DM.tSQL_CatalogRelation.Next; end; } { ChangeSQLQuery(DM.scsQOperat, ' update interface_relation set coordz = :coordz '+ ' where (side = :side) and '+ ' id_component in (select id_component from catalog_relation ' + ' where id_catalog = :id_catalog ) '); DM.scsQOperat.SetParamAsInteger('id_catalog', IDCatalog); DM.scsQOperat.SetParamAsInteger('side', ASide); DM.scsQOperat.SetParamAsFloat('CoordZ', ACoordZ); DM.scsQOperat.ExecQuery; DM.scsQOperat.Close; //SetInterfacesCoordZ(AInterfaces, ACoordZ); } IDCatalog := SCSTrace.ID; FigureNode := SCSTrace.TreeViewNode; if Not Assigned(FigureNode) then FigureNode := FindComponOrDirInTree(IDCatalog, false); if (FigureNode <> nil) and (FigureNode.Data <> nil) then begin FigureDat := FigureNode.Data; SetNodeState(FigureNode, FigureDat.ItemType, GEditKind); //FigureNode.ImageIndex := GetNodeImageIndex(FigureDat.ItemType, GEditKind, FigureDat.ObjectID); end; RefreshNode; //SCSTrace := TSCSCatalog.Create(F_ProjMan); //try //SCSTrace.LoadCatalogByID(IDCatalog, false, false); //F_ChoiceConnectSide.DefineTraceStyleInCAD(SCSTrace); //finally //SCSTrace.Free; //end; end; end; except on E: Exception do AddExceptionToLog('SetInterfacesCoordZInPM: '+E.Message); end; end; (* procedure SetLineFigureCoordZInPM(AIDFigure, ASide: Integer; ACoordZ: Double); var i: Integer; IDCatalog: Integer; FigureNode: TTreeNode; FigureDat: PObjectData; SCSTrace: TSCSCatalog; begin try //if (ASide < 1) or (ASide > 2) then Exit; ///// EXIT ///// FigureNode := nil; with F_ProjMan do begin {IDCatalog := DM.GetIDCatalogByIDFigure(AIDFigure); SetFilterToSQLMemTable(DM.tSQL_CatalogRelation, 'id_catalog = '''+IntTostr(IDCatalog)+''''); DM.tSQL_CatalogRelation.First; while Not DM.tSQL_CatalogRelation.Eof do begin SetFilterToSQLMemTable(DM.tSQL_InterfaceRelation, 'id_component = '''+IntTostr(DM.tSQL_CatalogRelation.FieldByName(fnIDComponent).AsInteger)+''''); DM.tSQL_InterfaceRelation.First; while Not DM.tSQL_InterfaceRelation.Eof do begin if DM.tSQL_InterfaceRelation.FieldByName(fnSide).AsInteger = ASide then begin DM.tSQL_InterfaceRelation.Edit; DM.tSQL_InterfaceRelation.FieldByName(fnCoordZ).AsFloat := ACoordZ; DM.tSQL_InterfaceRelation.Post; end; DM.tSQL_InterfaceRelation.Next; end; DM.tSQL_CatalogRelation.Next; end; } { ChangeSQLQuery(DM.scsQOperat, ' update interface_relation set coordz = :coordz '+ ' where (side = :side) and '+ ' id_component in (select id_component from catalog_relation ' + ' where id_catalog = :id_catalog ) '); DM.scsQOperat.SetParamAsInteger('id_catalog', IDCatalog); DM.scsQOperat.SetParamAsInteger('side', ASide); DM.scsQOperat.SetParamAsFloat('CoordZ', ACoordZ); DM.scsQOperat.ExecQuery; DM.scsQOperat.Close; //SetInterfacesCoordZ(AInterfaces, ACoordZ); } FigureNode := FindComponOrDirInTree(IDCatalog, false); if (FigureNode <> nil) and (FigureNode.Data <> nil) then begin FigureDat := FigureNode.Data; SetNodeImageIndex(FigureNode, FigureDat.ItemType, GEditKind, true); //FigureNode.ImageIndex := GetNodeImageIndex(FigureDat.ItemType, GEditKind, FigureDat.ObjectID); end; RefreshNode; //SCSTrace := TSCSCatalog.Create(F_ProjMan); //try SCSTrace := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); //SCSTrace.LoadCatalogByID(IDCatalog, false, false); F_ChoiceConnectSide.DefineTraceStyleInCAD(SCSTrace); //finally //SCSTrace.Free; //end; end; except on E: Exception do AddExceptionToLog('SetInterfacesCoordZInPM: '+E.Message); end; end; *) // ##### Устанавливает точечному объекту Высоту ##### procedure SetConFigureCoordZInPM(AIDFigure: Integer; ACoordZ: Double); var //IDCatalog: Integer; SCSCatalog: TSCSCatalog; begin //Exit; //#Del try with F_ProjMan do begin SCSCatalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if SCSCatalog <> nil then begin SCSCatalog.SetPropertyValueAsFloat(pnCoordZ, ACoordZ, true); if Assigned(SCSCatalog.TreeViewNode) then SetNodeState(SCSCatalog.TreeViewNode, SCSCatalog.ItemType, GEditKind); //ChangeConObjectCoordZ(SCSCatalog, ACoordZ); RefreshNode; end; end; except on E: Exception do AddExceptionToLog('SetConObjectCoordZInPM: '+E.Message); end; end; // ##### Изменяет свойство длины дли линейного объекта в МП ##### procedure SetLineFigureLengthInPM(AIDFigure: Integer; ALength: Double); var //IDCatalog: Integer; SCSCatalog: TSCSCatalog; begin //Exit; //#Del try with F_ProjMan do begin SCSCatalog := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSCatalog) then begin ChangeLineObjectLength(SCSCatalog, Abs(ALength)); RefreshNode; end; end; except on E: Exception do AddExceptionToLog('SetLineFigureHeightInPM: '+E.Message); end; end; function MakeCablingInPM(AIDObjectList: Tlist; ASaveForUndo: Boolean): Boolean; begin Result := false; try Result := F_ProjMan.F_ChoiceConnectSide.MakeCabling(AIDObjectList, ASaveForUndo); except on E: Exception do AddExceptionToLog('MakeCablingInPM: '+E.Message); end; end; function GetHowFillObjByEmptyBusy(AEmptyCnt, ABusyCnt: integer): TFillConnectConObj; begin Result := foNone; if (AEmptyCnt = 0) and (ABusyCnt = 0) then Result := foNone; if (AEmptyCnt = 0) and (ABusyCnt > 0) then Result := foBusy; if (AEmptyCnt > 0) and (ABusyCnt = 0) then Result := foEmpty; if (AEmptyCnt > 0) and (ABusyCnt > 0) then Result := foPartEmpty; end; function HowFillConnectConObj(AObject: TObject; AUseInterfFilter: Boolean): TFillConnectConObj; var //IDObject: Integer; Catalog: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; BusyInterfCount: integer; EmptyInterfCount: Integer; i, j: integer; FilterInfo: TFilterInfo; FilterBlock: TFilterBlock; begin Result := foNone; if AObject = nil then Exit; ///// EXIT ///// try try Catalog := TSCSCatalog(AObject); BusyInterfCount := 0; EmptyInterfCount := 0; if Catalog.ComponentReferences.Count > 0 then begin FilterInfo := nil; FilterBlock := nil; if AUseInterfFilter then if Catalog.ProjectOwner <> nil then FilterInfo := Catalog.ProjectOwner.GetFilterInfoByType(ftConnectedConObjects); if FilterInfo <> nil then if FilterInfo.UseInCAD then FilterBlock := FilterInfo.FilterBlock; for i := 0 to Catalog.ComponentReferences.Count - 1 do if Assigned(Catalog.ComponentReferences[i]) then begin SCSComponent := Catalog.ComponentReferences[i]; for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.TypeI = itFunctional) and (Interfac.Kind = ikNoSplit) then begin if (FilterBlock = nil) or IsVisibleInterfaceByFilter(Interfac, FilterBlock) then IncBusyEmptyInterface(Interfac, EmptyInterfCount, BusyInterfCount); {if Interfac.IsBusy = biTrue then Inc(BusyInterfCount) else Inc(EmptyInterfCount);} end; end; end; end; if (EmptyInterfCount = 0) and (BusyInterfCount = 0) then Result := foNone; if (EmptyInterfCount = 0) and (BusyInterfCount > 0) then Result := foBusy; if (EmptyInterfCount > 0) and (BusyInterfCount = 0) then Result := foEmpty; if (EmptyInterfCount > 0) and (BusyInterfCount > 0) then Result := foPartEmpty; except on E: Exception do AddExceptionToLog('HowFillConnectConObj: '+E.Message); end; finally //Catalog.Free; end; end; function HowFillConnectLineObj(AObject: TObject; AUseInterfFilter: Boolean): TFillConnectLineObj; var ObjID: Integer; Catalog: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; i, j: Integer; BusyInterfCount1: integer; EmptyInterfCount1: Integer; BusyInterfCount2: integer; EmptyInterfCount2: Integer; FilterInfo: TFilterInfo; FilterBlock: TFilterBlock; begin Result.FillingSide1 := foNone; Result.FillingSide2 := foNone; if AObject = nil then Exit; ///// EXIT ///// try try BusyInterfCount1 := 0; EmptyInterfCount1 := 0; BusyInterfCount2 := 0; EmptyInterfCount2 := 0; Catalog := TSCSCatalog(AObject); if Catalog.ComponentReferences.Count > 0 then begin FilterInfo := nil; FilterBlock := nil; if AUseInterfFilter then if Catalog.ProjectOwner <> nil then FilterInfo := Catalog.ProjectOwner.GetFilterInfoByType(ftConnectedLineCompons); if FilterInfo <> nil then if FilterInfo.UseInCAD then FilterBlock := FilterInfo.FilterBlock; for i := 0 to Catalog.ComponentReferences.Count - 1 do begin SCSComponent := Catalog.ComponentReferences.Items[i]; if SCSComponent.IsLine = biTrue then for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.TypeI = itFunctional) and (Interfac.Kind = ikNoSplit) then if (FilterBlock = nil) or IsVisibleInterfaceByFilter(Interfac, FilterBlock) then case Interfac.Side of 1: IncBusyEmptyInterface(Interfac, EmptyInterfCount1, BusyInterfCount1); {case Interfac.IsBusy of biTrue: BusyInterfCount1 := BusyInterfCount1 + 1; biFalse: EmptyInterfCount1 := EmptyInterfCount1 + 1; end;} 2: IncBusyEmptyInterface(Interfac, EmptyInterfCount2, BusyInterfCount2); {case Interfac.IsBusy of biTrue: BusyInterfCount2 := BusyInterfCount2 + 1; biFalse: EmptyInterfCount2 := EmptyInterfCount2 + 1; end;} end; end; end; end; Result.FillingSide1 := GetHowFillObjByEmptyBusy(EmptyInterfCount1, BusyInterfCount1); Result.FillingSide2 := GetHowFillObjByEmptyBusy(EmptyInterfCount2, BusyInterfCount2); (* with F_ProjMan.DM do begin ObjID := F_ProjMan.DM.GetIDCatalogByIDFigure(AIDFigure); {Catalog := TSCSCatalog.Create(TForm(F_ProjMan)); Catalog.LoadAllComponents(ObjID, false); for i := 0 to Catalog.SCSComponents.Count - 1 do begin ptrSCSComponent := Catalog.SCSComponents.Items[i]; if ptrSCSComponent.IsLine = biTrue then begin ptrSCSComponent.LoadInterfaces(-1, false); for j := 0 to ptrSCSComponent.Interfaces.Count - 1 do begin Interfac := ptrSCSComponent.Interfaces[j]; if Interfac.Kind = ikNoSplit then case Interfac.Side of 1: case Interfac.IsBusy of biTrue: BusyInterfCount1 := BusyInterfCount1 + 1; biFalse: EmptyInterfCount1 := EmptyInterfCount1 + 1; end; 2: case Interfac.IsBusy of biTrue: BusyInterfCount2 := BusyInterfCount2 + 1; biFalse: EmptyInterfCount2 := EmptyInterfCount2 + 1; end; end; end; end; end; } EmptyInterfCount1 := GetInterfCountFromObject(ObjID, ctCable, itFunctional, ikNoSplit, biFalse, 1); BusyInterfCount1 := GetInterfCountFromObject(ObjID, ctCable, itFunctional, ikNoSplit, biTrue, 1); EmptyInterfCount2 := GetInterfCountFromObject(ObjID, ctCable, itFunctional, ikNoSplit, biFalse, 2); BusyInterfCount2 := GetInterfCountFromObject(ObjID, ctCable, itFunctional, ikNoSplit, biTrue, 2); if (EmptyInterfCount1 = 0) and (BusyInterfCount1 = 0) then Result.FillingSide1 := foNone; if (EmptyInterfCount1 = 0) and (BusyInterfCount1 > 0) then Result.FillingSide1 := foBusy; if (EmptyInterfCount1 > 0) and (BusyInterfCount1 = 0) then Result.FillingSide1 := foEmpty; if (EmptyInterfCount1 > 0) and (BusyInterfCount1 > 0) then Result.FillingSide1 := foPartEmpty; if (EmptyInterfCount2 = 0) and (BusyInterfCount2 = 0) then Result.FillingSide2 := foNone; if (EmptyInterfCount2 = 0) and (BusyInterfCount2 > 0) then Result.FillingSide2 := foBusy; if (EmptyInterfCount2 > 0) and (BusyInterfCount2 = 0) then Result.FillingSide2 := foEmpty; if (EmptyInterfCount2 > 0) and (BusyInterfCount2 > 0) then Result.FillingSide2 := foPartEmpty; end; *) except on E: Exception do AddExceptionToLog('HowFillConnectLineObj: '+E.Message); end; finally //Catalog.Free; end; end; function HowFillCableCanal(AObject: TObject): TFillConnectConObj; var ObjID: Integer; Catalog: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; i, j: Integer; CurrBusySpace: Double; BusySpace: Double; EmptySpace: Double; TotalSpace: Double; TotalCapasitySpace: Double; //*** Общее вместимое сечение ListOwner: TSCSList; CableChannelFullness: Double; begin Result := foNone; if AObject = nil then Exit; //// EXIT //// try Catalog := TSCSCatalog(AObject); ListOwner := nil; CableChannelFullness := 0; if Catalog.SCSComponents.Count > 0 then CableChannelFullness := GetCableCanalFullnessKoef(Catalog.SCSComponents[0]) else begin ListOwner := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(Catalog.ListID); if ListOwner <> nil then CableChannelFullness := ListOwner.Setting.CableCanalFullnessKoef; end; with F_ProjMan do begin BusySpace := 0; EmptySpace := 0; TotalSpace := 0; TotalCapasitySpace := 0; for i := 0 to Catalog.ComponentReferences.Count - 1 do if Assigned(Catalog.ComponentReferences[i]) then begin SCSComponent := Catalog.ComponentReferences.Items[i]; if SCSComponent.IsLine = biTrue then for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.Gender = gtFemale) and (Interfac.TypeI = itConstructive) then if Interfac.Kind = ikNoSplit then begin CurrBusySpace := Interfac.GetInterfToValues; //DM.GetConnectedInterfacesValues(DM.scsQSelect, Interfac.ID); if CurrBusySpace < Interfac.ValueI then EmptySpace := EmptySpace + (Interfac.ValueI - CurrBusySpace); BusySpace := BusySpace + CurrBusySpace; TotalSpace := TotalSpace + Interfac.ValueI; end; end; end; if (EmptySpace = 0) and (BusySpace = 0) then Result := foNone; if (EmptySpace = 0) and (BusySpace > 0) then Result := foBusy; if (EmptySpace > 0) and (BusySpace = 0) then Result := foEmpty; if (EmptySpace > 0) and (BusySpace > 0) then Result := foPartEmpty; //*** Проверить не вылезла ли вместимость за рамки допустимого процента if Result <> foBusy then begin TotalCapasitySpace := (TotalSpace / 100) * CableChannelFullness; //*** Если занятое пространство больше общего вместимого, то каб-е каналы заняты полностью if BusySpace > 0 then if BusySpace >= TotalCapasitySpace then Result := foBusy; end; end; (* ListOwner := nil; with F_ProjMan do begin BusySpace := 0; EmptySpace := 0; TotalSpace := 0; TotalCapasitySpace := 0; //ObjID := DM.GetIDCatalogByIDFigure(AIDFigure); Catalog := TSCSCatalog.Create(TForm(F_ProjMan)); try Catalog.LoadCatalogByIDFigure(AIDFigure, false, false); Catalog.LoadAllComponentsByObjectID(Catalog.ID, [fiIsLine]); {ChangeSQLQuery(scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where (id_interf_rel = :id_interf) or (id_interf_to = :id_interf) '); } for i := 0 to Catalog.SCSComponents.Count - 1 do begin SCSComponent := Catalog.SCSComponents.Items[i]; if SCSComponent.IsLine = biTrue then begin SCSComponent.LoadInterfaces(-1, false); for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.Gender = gtFemale) and (Interfac.TypeI = itConstructive) then if Interfac.Kind = ikNoSplit then begin CurrBusySpace := DM.GetConnectedInterfacesValues(DM.scsQSelect, Interfac.ID); if CurrBusySpace < Interfac.ValueI then EmptySpace := EmptySpace + (Interfac.ValueI - CurrBusySpace); BusySpace := BusySpace + CurrBusySpace; TotalSpace := TotalSpace + Interfac.ValueI; end; end; end; end; if (EmptySpace = 0) and (BusySpace = 0) then Result := foNone; if (EmptySpace = 0) and (BusySpace > 0) then Result := foBusy; if (EmptySpace > 0) and (BusySpace = 0) then Result := foEmpty; if (EmptySpace > 0) and (BusySpace > 0) then Result := foPartEmpty; //*** Проверить не вылезла ли вместимость за рамки допустимого процента if Result <> foBusy then begin ListOwner := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(Catalog.ListID); if ListOwner <> nil then begin TotalCapasitySpace := (TotalSpace / 100) * ListOwner.Setting.CableCanalFullnessKoef; //*** Если занятое пространство больше общего вместимого, то каб-е каналы заняты полностью if BusySpace > 0 then if BusySpace >= TotalCapasitySpace then Result := foBusy; end; end; finally Catalog.Free; end; end; *) except on E: Exception do AddExceptionToLog('HowFillConnectLineObj: '+E.Message); end; end; function HowFillCablaCanalCorkInTrace(AObject: TObject): TFillConnectLineObj; var SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; Interfac: TSCSInterface; i, j: Integer; InterfCount: Integer; EmptySides1: Integer; BusySides1: Integer; HaveConectionInSide1: Boolean; EmptySides2: Integer; BusySides2: Integer; HaveConectionInSide2: Boolean; begin Result.FillingSide1 := foEmpty; Result.FillingSide2 := foEmpty; if AObject = nil then Exit; //// EXIT //// try EmptySides1 := 0; BusySides1 := 0; EmptySides2 := 0; BusySides2 := 0; SCSCatalog := TSCSCatalog(AObject); for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do if Assigned(SCSCatalog.ComponentReferences[i]) then begin SCSComponent := SCSCatalog.ComponentReferences[i]; if SCSComponent.ComponentType.SysName = ctsnCableChannel then begin HaveConectionInSide1 := false; HaveConectionInSide2 := false; for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.TypeI = itFunctional) and (( (Interfac.Side = 1) and Not(HaveConectionInSide1) )or ( (Interfac.Side = 2) and Not(HaveConectionInSide2) )) then begin //*** Проверить есть ли соединение на концы интерфейса //InterfCount := F_ProjMan.DM.GetIOfIRelCountByFulter('(id_interf_rel = '''+IntToStr(Interfac.ID)+''') or '+ // '(id_interf_to = '''+IntToStr(Interfac.ID)+''')', true); InterfCount := Interfac.ConnectedInterfaces.Count; if InterfCount > 0 then case Interfac.Side of 1: HaveConectionInSide1 := true; 2: HaveConectionInSide2 := true; end else case Interfac.Side of 1: HaveConectionInSide1 := false; 2: HaveConectionInSide2 := false; end end; end; if HaveConectionInSide1 then BusySides1 := BusySides1 + 1 else EmptySides1 := EmptySides1 + 1; if HaveConectionInSide2 then BusySides2 := BusySides2 + 1 else EmptySides2 := EmptySides2 + 1; end; end; Result.FillingSide1 := GetHowFillObjByEmptyBusy(EmptySides1, BusySides1); Result.FillingSide2 := GetHowFillObjByEmptyBusy(EmptySides2, BusySides2); (* SCSCatalog := TSCSCatalog.Create(Tform(F_ProjMan)); try SCSCatalog.LoadCatalogByIDFigure(AIDLineFigure, false, false); SCSCatalog.LoadAllComponentsByObjectID(SCSCatalog.ID, [fiIsLine, fiIDComponentType]); with F_ProjMan.DM do for i := 0 to SCSCatalog.SCSComponents.Count - 1 do begin SCSComponent := SCSCatalog.SCSComponents[i]; SCSComponent.LoadInterfacesByFi([fiID, fiTypeI, fiSide]); if SCSComponent.ID_ComponentType = ctCableCanal then begin HaveConectionInSide1 := false; HaveConectionInSide2 := false; for j := 0 to SCSComponent.Interfaces.Count - 1 do begin Interfac := SCSComponent.Interfaces[j]; if (Interfac.TypeI = itFunctional) and (( (Interfac.Side = 1) and Not(HaveConectionInSide1) )or ( (Interfac.Side = 2) and Not(HaveConectionInSide2) )) then begin //*** Проверить есть ли соединение на концы интерфейса InterfCount := GetIOfIRelCountByFulter('(id_interf_rel = '''+IntToStr(Interfac.ID)+''') or '+ '(id_interf_to = '''+IntToStr(Interfac.ID)+''')', true); if InterfCount > 0 then case Interfac.Side of 1: HaveConectionInSide1 := true; 2: HaveConectionInSide2 := true; end else case Interfac.Side of 1: HaveConectionInSide1 := false; 2: HaveConectionInSide2 := false; end { //*** Проверить есть ли соединение на концы интерфейса SetSQLToQuery(scsQSelect, ' select count(id) As Cnt from interfofinterf_relation '+ ' where (id_interf_rel = '''+IntToStr(Interfac.ID)+''') or '+ ' (id_interf_to = '''+IntToStr(Interfac.ID)+''') '); if scsQSelect.GetFNAsInteger('Cnt') > 0 then case Interfac.Side of 1: HaveConectionInSide1 := true; 2: HaveConectionInSide2 := true; end else case Interfac.Side of 1: HaveConectionInSide1 := false; 2: HaveConectionInSide2 := false; end } end; end; if HaveConectionInSide1 then BusySides1 := BusySides1 + 1 else EmptySides1 := EmptySides1 + 1; if HaveConectionInSide2 then BusySides2 := BusySides2 + 1 else EmptySides2 := EmptySides2 + 1; end; end; Result.FillingSide1 := GetHowFillObjByEmptyBusy(EmptySides1, BusySides1); Result.FillingSide2 := GetHowFillObjByEmptyBusy(EmptySides2, BusySides2); finally SCSCatalog.Free; end; *) except on E: Exception do AddExceptionToLog('HowFillCablaCanalCorkInTrace: '+E.Message); end; end; function GetObjDefectDegree(AObject: TObject): TDefectDegree; var DefectCount: Integer; NormalCount: Integer; i: Integer; SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; begin Result := dodNormal; DefectCount := 0; NormalCount := 0; SCSCatalog := TSCSCatalog(AObject); for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin SCSComponent := SCSCatalog.ComponentReferences[i]; if SCSComponent.GetPropertyValueAsBooleanDef(pnDefect, false) then begin DefectCount := DefectCount + 1; // чтобы не ганять лишний раз цыкл if NormalCount > 0 then Break; //// BREAK //// end else begin NormalCount := NormalCount + 1; // чтобы не ганять лишний раз цыкл if DefectCount > 0 then Break; //// BREAK //// end; end; if (NormalCount = 0) and (DefectCount > 0) then Result := dodDefect else if (NormalCount > 0) and (DefectCount > 0) then Result := dodPartDefect; end; // ##### Ведомость объектов ##### procedure RepObjectReport; //var IDCatalogList: Integer; begin Exit; {try with F_ProjMan do if CheckIsOpenProject(true) then begin IDCatalogList := DM.GetIDCatalogByIDList(GIDLastList); F_ResourceReport.ShowListObjectReport(IDCatalogList); end; except on E: Exception do AddExceptionToLog('RepObjectReport: '+E.Message); end;} end; // ##### Ведомость ресурсов ##### procedure RepResourceReport; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin ListObject := GSCSBase.CurrProject.CurrList; if Assigned(ListObject) then begin CreateFReportForm.Execute(ListObject, cBaseCommon32, fmRResources, true, true, true); end; end; except on E: Exception do AddExceptionToLog('RepResourceReport: '+E.Message); end; end; // ##### Ведомость кабелей ##### procedure RepCableReport; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //ListObject := GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderCableReport(ListObject, fmRCable); end; except on E: Exception do AddExceptionToLog('RepCableReport: '+E.Message); end; end; procedure RepCableExceedLength; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //ListObject := F_ProjMan.GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderCableReport(ListObject, fmRCableExceedLength); end; except on E: Exception do AddExceptionToLog('RepCableExceedLength: '+E.Message); end; end; procedure RepCableCanal; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //ListObject := F_ProjMan.GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderCableReport(ListObject, fmRCableCanal); end; except on E: Exception do AddExceptionToLog('RepCableCanal: '+E.Message); end; end; procedure RepDisparityComponColor; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //IDCatalogList := DM.GetIDCatalogByIDList(GIDLastList); //ListObject := TSCSCatalog.Create(TForm(F_ProjMan)); //try //ListObject.LoadCatalogByID(IDCatalogList); //ListObject := GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderDisparityComponReport(ListObject, fmRDisparityComponColor); //finally // FreeAndNil(ListObject); //end; end; except on E: Exception do AddExceptionToLog('RepDisparityComponColor: '+E.Message); end; end; procedure RepDisparityComponProducer; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //IDCatalogList := DM.GetIDCatalogByIDList(GIDLastList); //ListObject := TSCSCatalog.Create(TForm(F_ProjMan)); //try // ListObject.LoadCatalogByID(IDCatalogList); //ListObject := GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderDisparityComponReport(ListObject, fmRDisparityComponProducer); //finally // FreeAndNil(ListObject); //end; end; except on E: Exception do AddExceptionToLog('RepDisparityComponProducer: '+E.Message); end; end; procedure RepCAbleJournal; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //ListObject := GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderCableJournal(ListObject); end; except on E: Exception do AddExceptionToLog('RepJoining: '+E.Message); end; end; procedure RepCableJournalExt; var List: TSCSCatalog; begin //List := TSCSCatalog(F_ProjMan.GSCSBase.CurrProject.CurrList); //if CheckIsOpenProject(true) then // if Assigned(List) then // F_ProjMan.F_ResourceReport.ShowFolderCableJournalExt(List); end; procedure RepSpecification; var //IDCatalogList: Integer; ListObject: TSCSCatalog; begin try with F_ProjMan do if CheckIsOpenProject(true) then begin //ListObject := GSCSBase.CurrProject.CurrList; //if Assigned(ListObject) then // F_ResourceReport.ShowFolderSpecificationReport(ListObject); end; except on E: Exception do AddExceptionToLog('RepSpecification: '+E.Message); end; end; procedure RepWizard; begin F_ProjMan.CreateFResourceReport.ShowWizard([rkProject]); end; procedure RepMarkPages; begin F_ProjMan.CreateFResourceReport.ShowWizard([rkMarkPages]); end; procedure ShowCurrencyDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkCurrency; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkCurrency, fmView); end; procedure ShowNetTypeDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkNetType; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkNetType, fmView); end; procedure ShowInterfaceDirectory; begin with F_NormBase do begin //F_CaseForm.GViewKind := vkInterface; //F_CaseForm.GFormMode := fmView; //F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkInterface, fmView); DM.SelectInterfaces(Tree_Catalog.Selected); end; end; { procedure ShowInterfaceAccordanceDirectory; begin F_NormBase.F_CaseForm.GViewKind := vkInterfaceAccordance; F_NormBase.F_CaseForm.GFormMode := fmView; F_NormBase.F_CaseForm.ShowModal; end; } procedure ShowPropertyDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkProperty; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.GItemType := itNone; F_NormBase.F_CaseForm.Execute(vkProperty, fmView); F_NormBase.DM.SelectComponProperty(nil); end; procedure ShowObjectIconsDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkObjectIcons; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkObjectIcons, fmView); end; procedure ShowProducersDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkProducers; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkProducers, fmView); end; procedure ShowComponentTypesDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkComponentType; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkComponentType, fmView); end; procedure ShowNormsDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkNorm; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkNorm, fmView); end; procedure ShowResourcesDirectory; begin //F_NormBase.F_CaseForm.GViewKind := vkResource; //F_NormBase.F_CaseForm.GFormMode := fmView; //F_NormBase.F_CaseForm.ShowModal; F_NormBase.F_CaseForm.Execute(vkResource, fmView); end; procedure ShowSuppliesKinds; begin F_NormBase.F_CaseForm.Execute(VKSuppliesKind, fmView); end; procedure ShowNDSDirectory; var OldNDS: Double; ID_Component : Integer; FldList: TStringList; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // { function GetNewPrice(APrice: Double): Double; var ChPrice: Double; begin with F_NormBase do begin ChPrice := APrice - APrice * (OldNDS / (100 + OldNDS) ); // Цена без НДС ChPrice := ChPrice + ChPrice * (GNDS / 100); end; Result := ChPrice; end; procedure RefreshPriceFields(AFormBase: TForm; ATableName: String; APriceFields: TStringList); var IDList: TList; i, j: Integer; CurrID: Integer; PriceValue: Double; begin try try with TF_Main(AFormBase).DM do begin IDList := TList.Create; SetSQLToQuery(scsQSelect, ' select id from '+ATableName+' '); IntFieldToList(IDList, scsQSelect, 'id'); for i := 0 to APriceFields.Count - 1 do begin scsQSelect.Close; scsQSelect.SQL.Clear; scsQSelect.SQL.Add(' select '+APriceFields.Strings[i]+' from '+ATableName+ ' where id = :id '); scsQOperat.Close; scsQOperat.SQL.Clear; scsQOperat.SQL.Add(' update '+ATableName+' set '+ APriceFields.Strings[i]+' = :PriceValue '+ ' where id = :id '); for j := 0 to IDList.Count - 1 do begin CurrID := Integer(IDList.Items[j]^); scsQSelect.Close; scsQSelect.SetParamAsInteger('id', CurrID); scsQSelect.ExecQuery; PriceValue := 0; PriceValue := scsQSelect.GetFNAsFloat(APriceFields.Strings[i]); PriceValue := GetNewPrice(PriceValue); PriceValue := RoundX(PriceValue, 7); scsQOperat.Close; scsQOperat.SetParamAsFloat('PriceValue', PriceValue); scsQOperat.SetParamAsInteger('id', CurrID); scsQOperat.ExecQuery; end; end; end; except on E: Exception do AddExceptionToLog('TF_ActiveCurrency.RefreshPriceFields: '+E.Message); end; finally FreeList(IDList); end; end; } begin with F_NormBase do begin OldNDS := GNDS; //F_NDS.GValue := GNDS; if F_NDS.Execute(GNDS) then //if F_NDS.ShowModal = mrOK then if OldNDS <> F_NDS.FValue then begin GNDS := F_NDS.FValue; OldTick := GetTickCount; if F_NDS.cbCanRecalcPrices.Checked then begin Screen.Cursor := crHourGlass; try ChangePricesByNDS(OldNDS, GNDS, DM.Query_Select, DM.Query_Operat); //FldList := TStringList.Create; //FldList.Add('price'); //FldList.Add('price_calc'); //RefreshPriceFields(TForm(F_NormBase), 'component', FldList); //RefreshPriceFields(TForm(F_ProjMan), 'component', FldList); //FProjectMan.Tree_Catalog.OnChange(FProjectMan.Tree_Catalog, FProjectMan.Tree_Catalog.Selected); FNormBase.Tree_Catalog.OnChange(FNormBase.Tree_Catalog, FNormBase.Tree_Catalog.Selected); finally Screen.Cursor := crDefault; //FreeAndNil(FldList); end; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; end; end; procedure PackNormBase; begin if F_NormBase <> nil then F_NormBase.Act_PackBase.Execute; end; procedure PackProjMan; begin if F_ProjMan <> nil then F_ProjMan.Act_PackBase.Execute; end; procedure BackUpBase(ADefDBMode: TDBKind); begin F_NormBase.CreateFBackUpBase.Execute(fmBackUp, ADefDBMode); end; procedure RestoreBase; begin F_NormBase.CreateFBackUpBase.Execute(fmRestore, bkNone); end; procedure ShowMasterUpdatePriceInNB; begin if Not F_NormBase.CheckWriteNB(false) then MessageModal(cNBIsReadOnly, ApplicationName, MB_ICONINFORMATION or MB_OK) else F_NormBase.CreateFMasterUpdatePrice.Execute(fmUpdateCompons, nil); end; procedure ChoiceNBPath; begin //F_NormBase.Act_ChoiceNBPath.Execute; end; procedure ChoicePMPath; begin F_NormBase.Act_ChoicePMPath.Execute; end; procedure ChoiceBaseOptions(ASettingTypeIndex: Integer = stiNone); begin F_NormBase.CreateFBaseOptions.ChangeOptions(ASettingTypeIndex); end; function GetPathToNBEmpty: String; var DirWithEmtpyBase: String; begin {$if Defined(ES_GRAPH_SC)} DirWithEmtpyBase := ExeDir + '\' + dnAdmin; {$else} DirWithEmtpyBase := ExtractFileDir(Application.ExeName)+'\'+dnAdmin; {$ifend} //if Not DirectoryExists(DirWithEmtpyBase) then // CreateDir(DirWithEmtpyBase); DefineDir(DirWithEmtpyBase); Result := DirWithEmtpyBase+'\'+fnNBEmty; end; function GetPathToPackedTmp(AFileNoExists: Boolean): String; begin Result := GetPathToSCSTmpDir+'\'+fnPackedTmp; if AFileNoExists and FileExists(Result) then Result := GetNoExistsFileNameForCopy(Result); end; function FullRemoveDir(ADir: string; ADeleteAllFilesAndFolders, ARemoveRoot: boolean): Boolean; var FileName: string; SrcDirName: string; FindRes: Integer; SRec: TSearchRec; begin Result := False; if not DirectoryExists(ADir) then exit; Result := True; //*** Добавляем слэш в конце и задаем маску - "все файлы и директории" SrcDirName := IncludeTrailingBackslash(ADir); FindRes := FindFirst(SrcDirName + '*', faAnyFile, SRec); try while FindRes = 0 do begin //*** Получаем полный путь к файлу или директорию FileName := SrcDirName + SRec.Name; //*** Если это директория if SRec.Attr = faDirectory then begin //*** Рекурсивный вызов этой же функции с ключом удаления корня if (SRec.Name <> '') and (SRec.Name <> '.') and (SRec.Name <> '..') then begin if ADeleteAllFilesAndFolders then FileSetAttr(FileName, faArchive); Result := FullRemoveDir(FileName, ADeleteAllFilesAndFolders, True); end; end else //*** Иначе удаляем файл begin if ADeleteAllFilesAndFolders then FileSetAttr(FileName, faArchive); Result := SysUtils.DeleteFile(FileName); end; //*** Берем следующий файл или директорию FindRes := FindNext(SRec); end; finally SysUtils.FindClose(SRec); end; if not Result then exit; if ARemoveRoot then // Если необходимо удалить корень - удаляем if not RemoveDir(SrcDirName) then Result := false; end; function GetDirFiles(const Path: string): TStringList; var SR: TSearchRec; begin Result := TStringList.Create; if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then begin repeat if (SR.Attr <> faDirectory) then begin Result.Add(SR.Name); end; until FindNext(SR) <> 0; FindClose(SR); end; end; procedure ClearSCSTemDirs; var DirPath: String; Buffer: array[0..1023] of Char; begin try DirPath := GetPathToSCSCADDir(false); if DirectoryExists(DirPath) then FullRemoveDir(DirPath, true, false); DirPath := GetPathToSCSUndoDir(false); if DirectoryExists(DirPath) then FullRemoveDir(DirPath, true, false); // *** IGOR *** //08.09.2011 SetString(DirPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); DirPath := GetPathToUndoDir(false); //08.09.2011 DirPath + 'Undo\'; if DirectoryExists(DirPath) then FullRemoveDir(DirPath, true, false); //08.09.2011 SetString(DirPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); DirPath := GetPathToRedoDir(false); //08.09.2011 DirPath + 'Redo\'; if DirectoryExists(DirPath) then FullRemoveDir(DirPath, true, false); except on E: Exception do AddExceptionToLogEx('ClearSCSCADDir', E.Message); end; end; function CreateUniqueDirInSCSTmp: String; var i: Integer; begin Result := ''; i := 0; while True do begin Result := GetPathToSCSTmpDir +'\'+ GetUniqueFileName('', ''); CreateDir(Result); Inc(i); if (i=15) or DirectoryExists(Result) then Break; //// BREAK //// end; end; function GetPathToDefListSettings: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir + '\' + dnData + '\' + fnDefaultListSettings; {$else} Result := ExtractFileDir(paramstr(0)) + '\' + dnData + '\' + fnDefaultListSettings; {$ifend} end; function GetPathToDefNB: string; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir + '\' + DefNBPath; {$else} Result := extractfilepath(paramstr(0)) + DefNBPath; {$ifend} end; function GetPathToDefProjSettings: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir +'\'+ dnData+'\'+fnDefaultProjSettings; {$else} Result := ExtractFileDir(paramstr(0)) +'\'+ dnData+'\'+fnDefaultProjSettings; {$ifend} end; function GetPathToDevelopment: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir + '\' + dnDevelopment; {$else} Result := ExtractFileDir(Application.ExeName)+'\'+dnDevelopment; {$ifend} if Not DirectoryExists(Result) then CreateDir(Result); end; function GetPathToExeLoader: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir +'\'+ fnExeLoader; {$else} Result := ExtractFileDir(ParamStr(0)) +'\'+ fnExeLoader; {$ifend} end; function GetPathToHelp(aRelative: Boolean): String; begin {$if Defined(ES_GRAPH_SC)} if Not aRelative then Result := ExeDir + '\Help' else Result := 'Help'; {$else} if Not aRelative then Result := ExtractFileDir(Application.ExeName)+'\Help' else Result := 'Help'; {$ifend} end; function GetPathToNBComponFavorites: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir +'\'+ fnNBComponFavorites; {$else} Result := ExtractFileDir(ParamStr(0)) +'\'+ fnNBComponFavorites; {$ifend} end; function GetPathToNBComponFilter: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir +'\'+ fnNBComponFilter; {$else} Result := ExtractFileDir(ParamStr(0)) +'\'+ fnNBComponFilter; {$ifend} end; function GetPathToNBComponGroups: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir; {$else} Result := ExtractFileDir(ParamStr(0)); {$ifend} Result := AddCreateDirToPath(Result, dnNormBase) + '\' + fNBComponGroups; end; function GetPathToProjectTmp: String; begin Result := GetPathToSCSTmpDir+'\'+fnProjectTmp; end; function GetPathToProjectFilterTmp(AFileNoExists: Boolean): String; begin Result := GetPathToSCSTmpDir+'\'+fnProjectFilterTmp; if AFileNoExists and FileExists(Result) then Result := GetNoExistsFileNameForCopy(Result); end; function GetPathToRedoDir(ADefine: Boolean=true): String; begin Result := GetAnsiTempPath + dnRedo+'\'; if ADefine then DefineDir(Result); end; function GetPathToRepDesignLang: String; begin {$if Defined(ES_GRAPH_SC)} Result := ExeDir + '\' + dnReports + '\' + GSCSIni.PM.RepDesignLanguageFile; {$else} Result := ExtractFileDir(paramstr(0))+'\'+ dnReports+'\'+GSCSIni.PM.RepDesignLanguageFile; {$ifend} end; function GetPathToSCSCADDir(AWithCreate: Boolean=false): string; begin Result := GetAnsiTempPath + dnSCSCAD; //if AWithCreate and Not DirectoryExists(Result) then // if Not CreateDir(Result) then // raise Exception.Create(cSCSComponent_Msg11); if AWithCreate and Not DefineDir(Result) then raise Exception.Create(cSCSComponent_Msg11); end; function GetPathToSCSTmpDir: String; begin //Result := ExtractFileDir(paramstr(0))+'\'+ dnTemp; Result := GetAnsiTempPath + dnSCS; //if Not DirectoryExists(Result) then // if Not CreateDir(Result) then // Result := GetAnsiTempPath; if Not DefineDir(Result) then Result := GetAnsiTempPath; end; function GetPathToSCSUndoDir(ADefine: Boolean=true): String; begin Result := GetAnsiTempPath + dnSCSUndo; //if Not DirectoryExists(Result) then // if Not CreateDir(Result) then // Result := GetAnsiTempPath; if ADefine and Not DefineDir(Result) then Result := GetAnsiTempPath; end; //Tolik 11/07/2025 -- function GetPathToSCSUndoUniqDir(aFor3D: Boolean = false): String; var i: Integer; begin Result := ''; if aFor3D then begin Result := GetPathToSCSUndoDir +'\' + '3D'; end else begin i := 0; while True do begin Result := GetPathToSCSUndoDir +'\'+ GetUniqueFileName('', ''); Inc(i); if (i=15) or DirectoryExists(Result) then Break; //// BREAK //// end; end; end; { function GetPathToSCSUndoUniqDir: String; var i: Integer; begin Result := ''; i := 0; while True do begin Result := GetPathToSCSUndoDir +'\'+ GetUniqueFileName('', ''); Inc(i); if (i=15) or DirectoryExists(Result) then Break; //// BREAK //// end; end; } function GetPathToUndoDir(ADefine: Boolean=true): String; begin Result := GetAnsiTempPath + dnUndo+'\'; if ADefine then DefineDir(Result); end; function GetPathToUnPackedTmp(AFileNoExists: Boolean): String; begin Result := GetPathToSCSTmpDir+'\'+fnUnPackedTmp; if AFileNoExists and FileExists(Result) then Result := GetNoExistsFileNameForCopy(Result); end; function GetPathToUserReportFile(ARepFileName: String): String; var ReportsDir: String; UserReportsDir: String; begin //Result := ExtractFileDir(ParamStr(0))+'\'+dnReports+'\'+dnUser+'\'+ARepFileName; Result := ''; {$if Defined(ES_GRAPH_SC)} ReportsDir := ExeDir + '\' + dnReports; {$else} ReportsDir := ExtractFileDir(ParamStr(0))+'\'+dnReports; {$ifend} if Not DirectoryExists(ReportsDir) then CreateDir(ReportsDir); if DirectoryExists(ReportsDir) then begin UserReportsDir := ReportsDir+'\'+dnUser; if Not DirectoryExists(UserReportsDir) then CreateDir(UserReportsDir); if DirectoryExists(UserReportsDir) then Result := UserReportsDir + '\'+ARepFileName else raise Exception.Create(cResourceReport_Msg11 + UserReportsDir); end else raise Exception.Create(cResourceReport_Msg11 + ReportsDir); end; procedure ShowLog; begin if GLog <> nil then F_NormBase.F_AnswerToQuast.ShowContextHelp(cBaseCommon48, GLog.Text, true); end; procedure MakeProject; begin F_ProjMan.Act_MakeProject.Execute; end; procedure OpenProjectAtCurrNode; begin F_ProjMan.Act_OpenProject.Execute; end; function CloseCurrProject(ACloseApplication: Boolean; AMessageIfClosed: Boolean = true): Integer; begin Result := F_ProjMan.CloseProject(ACloseApplication, AMessageIfClosed); end; procedure LoadNewProjectFromFile; begin F_ProjMan.Act_LoadProjectFromFile.Execute; end; procedure MasterCableTracing; begin F_ProjMan.CreateFMasterCableCanalTracing.Execute(0, '', ctsnCable, GCompTypeSysNameCables); end; procedure MasterCableCanalTracing; begin F_ProjMan.CreateFMasterCableCanalTracing.Execute(0, '', ctsnCableChannel, GCompTypeSysNameCableChannels); end; function SaveCurrentProject: Boolean; begin Result := true; if F_ProjMan <> nil then with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then if CheckWriteProj(GSCSBase.CurrProject.CurrID, true) then begin Result := GSCSBase.CurrProject.SaveProject; //BeginProgress; //try // GSCSBase.CurrProject.SaveProject; //finally // EndProgress; //end; end; end; procedure SaveProjectToFile; begin F_ProjMan.Act_SaveProjectToFile.Execute; end; procedure ShowConfigurator; begin if Assigned(F_ProjMan) then if Assigned(F_ProjMan.GSCSBase) then if F_ProjMan.GSCSBase.Active then begin if F_ProjMan.GSCSBase.CurrProject.Active then F_ProjMan.Act_ConnectConfigurator.Execute //F_ProjMan.F_MakeEditCrossConnection.ShowConnectConfigurator(F_ProjMan.GSCSBase.CurrProject, fmCableConfigurator); else ShowMessageByType(0, smtDisplay, cBaseCommon33, ApplicationName, MB_ICONINFORMATION or MB_OK); end; end; procedure ShowConfiguratorForPointObject(AIDPointFigure: Integer); var SCSCatalog: TSCSCatalog; begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDPointFigure); if SCSCatalog <> nil then begin F_ProjMan.CreateFMakeEditCrossConnection.ShowPointObjectConfigurator(SCSCatalog); end; end; procedure ShowKalc; begin F_Kalc.Execute; {if F_Kalc.Visible then SetForegroundWindow(F_Kalc.Handle) else begin F_Kalc.FormStyle := fsStayOnTop; F_Kalc.Show; end;} end; procedure ShowConnDisconnComponsForList(AListID: Integer; AModeConnDisconnCompons: TModeConnDisconnCompons); var SCSList: TSCSList; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then F_ProjMan.ShowConnDisconnCompons(SCSList, AModeConnDisconnCompons); end; function GetIDLineComponFromNBByIDInterface(AIDInterface: Integer): Tlist; var ComponIDList: TIntList; i: Integer; //ListItem: TListItem; //ptrID: ^Integer; //IDCurrCompon: Integer; //CaptionClose: String; //ptrLineCompons: PIDAndCaption; SCSComponent: TSCSComponent; //SCSInterface: TSCSInterface; //ResComponent: TSCSComponent; //ResList: TList; begin Result := nil; Result := TList.Create; try with F_NormBase do begin ComponIDList := TIntList.Create; try //SetSQLToQuery(DM.scsQSelect, ' select id from component '+ // ' where (id in (select id_component from catalog_relation)) and '+ // ' (isLine = '''+IntToStr(biTrue)+''') and '+ // ' (id in (select id_component from interface_relation '+ // ' where (id_interface = '''+IntToStr(AIDInterface)+''') and '+ // ' (typei = '''+IntToStr(itFunctional)+''') )) '); //SetSQLToQuery(DM.scsQSelect, ' select id from component '+ // 'where (isLine = '''+IntToStr(biTrue)+''') and '+ // '(id in (select id_component from interface_relation '+ // 'where (id_interface = '''+IntToStr(AIDInterface)+''') and '+ // '(typei = '''+IntToStr(itFunctional)+''') )) '); SetSQLToFIBQuery(DM.Query_Select, ' select DISTINCT component.id, '+fnName+', '+fnArticulProducer+', '+fnArticulDistributor+', '+fnIDProducer+ ' from component, interface_relation '+ 'where (isLine = '''+IntToStr(biTrue)+''') and '+ '(id_interface = '''+IntToStr(AIDInterface)+''') and '+ '(typei = '''+IntToStr(itFunctional)+''') and '+ '(component.id = interface_relation.id_component) '+ 'order by name' ); while Not DM.Query_Select.Eof do begin SCSComponent := TSCSComponent.Create(TForm(F_NormBase)); SCSComponent.ID := DM.Query_Select.FN(fnID).AsInteger; SCSComponent.Name := DM.Query_Select.FN(fnName).AsString; SCSComponent.ArticulDistributor := DM.Query_Select.FN(fnArticulDistributor).AsString; SCSComponent.ArticulProducer := DM.Query_Select.FN(fnArticulProducer).AsString; SCSComponent.ID_Producer := DM.Query_Select.FN(fnIDProducer).AsInteger; Result.Add(SCSComponent); DM.Query_Select.Next; end; { IntFIBFieldToIntList(ComponIDList, DM.Query_Select, fnID); for i := 0 to ComponIDList.Count - 1 do begin SCSComponent := TSCSComponent.Create(TForm(F_NormBase)); SCSComponent.LoadComponentByID(Integer(ComponIDList[i]), false); Result.Add(SCSComponent); end;} //if ResList.Count = 0 then // ResList.Free //else // Result := ResList; finally FreeAndNil(ComponIDList); end; end; except on E: Exception do AddExceptionToLog('GetIDLineComponFromNBForAutoTracingByIDInterface: '+E.Message); end; end; // НОВЫЕ ПРОЦЕДУРЫ !!!!!!!!!!!!!!!!!!!!! { // ПРИ СОЗДАНИИ ЛИСТА В МП СОЗДАТЬ ЕГО НА CAD-е Procedure AddListInCAD(ListID: Integer; ListName: String); begin Exit; end; // ПРИ ПЕРЕКЛЮЧЕНИИ ЛИСТА В МП ПЕРЕКЛЮЧИТЬ ЕГО НА CAD-е Procedure SwitchListInCAD(ListID: Integer; ListName: String); begin Exit; end; // ПРИ ПЕРЕИМЕНОВАНИИ ЛИСТА В МП ПЕРЕКЛЮЧИТЬ ЕГО НА CAD-е Procedure RenameListInCAD(ListID: Integer; OldListName, NewListName: String); begin Exit; end; } // Tolik 26/09/2018 -- //function AutoConnectOverRaiseLine(APointObjectID: Integer; ARaiseLineID: Integer; // AJoinedBeforeRaise, AJoinedAfterRaise: TList; ALineType: TLineType): Boolean; function AutoConnectOverRaiseLine(APointObjectID: Integer; ARaiseLineID: Integer; AJoinedBeforeRaise, AJoinedAfterRaise: TList; ALineType: TLineType; aNoCopyList: TList = nil): Boolean; // begin //Exit; //#Del Result := false; try if (AJoinedBeforeRaise = nil) and (AJoinedAfterRaise <> nil) then Exit; ///// EXIT ///// Result := F_ProjMan.F_ChoiceConnectSide.AutoConnectOverRaiseLine(APointObjectID, ARaiseLineID, AJoinedBeforeRaise, AJoinedAfterRaise, ALineType, aNoCopyList); except on E: Exception do AddExceptionToLog('AutoConnectOverRaiseLine: '+E.Message); end; end; function AutoDisconnectOverRaiseLine(ARaiseLineID: Integer; AJoinedBeforeRaise, AJoinedAfterRaise: TList): Boolean; begin Result := false; try if (AJoinedBeforeRaise = nil) and (AJoinedAfterRaise <> nil) then Exit; ///// EXIT ///// Result := F_ProjMan.F_ChoiceConnectSide.AutoDisconnectOverRaiseLine(ARaiseLineID, AJoinedBeforeRaise, AJoinedAfterRaise); except on E: Exception do AddExceptionToLog('AutoDisconnectOverRaiseLine: '+E.Message); end; end; function IsSelectServerAsDefault: Boolean; begin Result := false; try if GCadForm <> nil then if GEndPoint <> nil then Result := true; except on E: Exception do AddExceptionToLog('IsSelectServerAsDefault: '+E.Message); end; end; // ##### Вызов свойств (настроек объекта) ##### procedure ShowObjectProps(AIDObject: Integer); begin try GPopupFigure := nil; FSCS_Main.aObjProperties.Execute; except on E: Exception do AddExceptionToLog('ShowObjectProps: '+E.Message); end; end; // ##### Вызовет форму создания нового Проекта ##### procedure MakeNewProject; begin BaseBeginUpdate; try FSCS_Main.aNew.Execute; finally BaseEndUpdate; end; end; // ##### Вызовет форму создания нового листа ##### procedure MakeNewList; begin FSCS_Main.aNewList.Execute; end; function ShowCurrProjectProperties(ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; var OldProjectParams: TProjectParams; OldProjectCurrency: TCurrency; ProjectParams: TProjectParams; ProjectCurrency: TCurrency; CurrListNode: TTreeNode; begin Result := false; with F_ProjMan do if GSCSBase.CurrProject.Active then begin ProjectParams := GetCurrProjectParams; //19.05.2009 GSCSBase.CurrProject.GetParams; OldProjectCurrency := GSCSBase.CurrProject.GetCurrency(ctMain); OldProjectParams := ProjectParams; if MakeEditProject(meEdit, GSCSBase.CurrProject.CurrID, ProjectParams, ASpravochnikKind, AGUIDToLocate) then begin Result := true; GSCSBase.CurrProject.LoadParams(ProjectParams); GSCSBase.CurrProject.SaveMainFields; //GSCSBase.CurrProject.Save; ProjectCurrency := GSCSBase.CurrProject.GetCurrency(ctMain); if Assigned(GSCSBase.CurrProject.TreeViewNode) then GSCSBase.CurrProject.TreeViewNode.Text := GetNameNode(GSCSBase.CurrProject.TreeViewNode, GSCSBase.CurrProject, true, true); //if (Abs(OldProjectParams.Setting.CurrencyRatio - ProjectParams.Setting.CurrencyRatio) > 0.01) or // (OldProjectParams.Setting.CurrencyKolvo <> ProjectParams.Setting.CurrencyKolvo) then // GSCSBase.CurrProject.RefreshPricesAfterChangeCurrency(OldProjectCurrency, ProjectCurrency, true); if OldProjectCurrency.GUID <> ProjectCurrency.GUID then begin //*** Обновить измененное значение предыдущей валюты OldProjectCurrency := GSCSBase.CurrProject.Spravochnik.GetCurrencyDataByGUID(OldProjectCurrency.GUID); GSCSBase.CurrProject.RefreshPricesAfterChangeCurrency(OldProjectCurrency, ProjectCurrency, true); end; // Применяем свойства справочных ресурсов, норм для всех что есть на компонентах GSCSBase.CurrProject.ApplySpavDataForObjects; if ProjectParams.ServCanRecalcPricesByNDSChange and (Abs(OldProjectParams.Setting.NDS - ProjectParams.Setting.NDS) > 0.01) then GSCSBase.CurrProject.RefreshComponsPriceAfterChangeNDS(OldProjectParams.Setting.NDS, ProjectParams.Setting.NDS, true); GSCSBase.CurrProject.SetPriceParamsToForm; if OldProjectParams.Setting.ListsInReverseOrder <> ProjectParams.Setting.ListsInReverseOrder then if GSCSBase.CurrProject.TreeViewNode <> nil then begin GSCSBase.CurrProject.SetItemsFTreeNodeToNil; DeleteChildNodes(GSCSBase.CurrProject.TreeViewNode); ClearTVNodeFieldInChildObjects(GSCSBase.CurrProject, false); AddNodes(GSCSBase.CurrProject.TreeViewNode); CurrListNode := nil; if GSCSBase.CurrProject.CurrList <> nil then if GSCSBase.CurrProject.CurrList.TreeViewNode <> nil then Tree_Catalog.Selected := GSCSBase.CurrProject.CurrList.TreeViewNode; end; if (Abs(OldProjectParams.Setting.HeightThroughFloor - ProjectParams.Setting.HeightThroughFloor) > cnstCmpLenDelta) then GSCSBase.CurrProject.RefreshWholeLengthThroughFloorComponsInFuture; SetCurrencyBriefToControls; ShowPrice; RefreshNode; //*** Изменить наим-е на рамках if OldProjectParams.Caption <> GSCSBase.CurrProject.GetParams.Caption then begin if GCadForm <> nil then GCadForm.FormActivate(GCadForm); //13.09.2010 RenameProjectOnFrame; end; RenameProjectOnFrame(OldProjectParams); GSCSBase.CurrProject.NotifyChange; end; end else ShowMessageByType(0, smtDisplay, cBaseCommon34, Application.Title, MB_OK or MB_ICONINFORMATION); end; function ShowCurrListProperties(ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; var ListParams: TListParams; begin Result := false; if F_ProjMan <> nil then if (F_ProjMan.GSCSBase <> nil) and (F_ProjMan.GSCSBase.CurrProject <> nil) then if F_ProjMan.GSCSBase.CurrProject.CurrList <> nil then begin ListParams := F_ProjMan.GSCSBase.CurrProject.CurrList.GetParams; MakeEditList(meEdit, ListParams, True, ASpravochnikKind, AGUIDToLocate); Result := true; end; end; // ##### Показать свойства листа ##### procedure ShowListProps; begin FSCS_Main.aListProperties.Execute; end; procedure ShowRoomProps(ARoomID: Integer); var SCSCatalog: TSCSCatalog; SCSObject: TSCSCatalog; SCSList: TSCSList; OldObjectParams: TObjectParams; ObjectParams: TObjectParams; i, j, k: Integer; Cabinet: TFigure; vList: TF_CAD; isUserSquare: Boolean; //Tolik 16/09/2020 -- ApplyClassName: String; SelList: TList; SelCatalog, ListCatalog: TSCSCatalog; CurrFigure: TFigure; CurrCad, SavedGCadForm: TF_Cad; RefreshFlag: Boolean; // Tolik 20/01/2021 function CheckisSimple: Boolean; var i: integer; begin Result := False; // Не выбрана ни одна галочка области применения -- значит как раньше if not F_ProjMan.F_ObjectParams.cbApplySelected.Checked then if not F_ProjMan.F_ObjectParams.cbApplyByProj.Checked then if not F_ProjMan.F_ObjectParams.cbApplyByList.Checked then begin Result := True; exit; end; // Не выбрана ни одна галочка применения свойств -- значит как раньше if not F_ProjMan.F_ObjectParams.cbDesignation.Checked then if not F_ProjMan.F_ObjectParams.cbDesignPos.Checked then if not F_ProjMan.F_ObjectParams.cbNumPos.Checked then if not F_ProjMan.F_ObjectParams.cbFontSize.Checked then if not F_ProjMan.F_ObjectParams.cbCeilingHeightCopy.Checked then if not F_ProjMan.F_ObjectParams.cbCabinetCopy.Checked then if not F_ProjMan.F_ObjectParams.cbAreaCopy.Checked then if not F_ProjMan.F_ObjectParams.cbTabooAreaCopy.Checked then begin Result := True; exit; end; //Если только для выбранных if F_ProjMan.F_ObjectParams.cbApplySelected.Checked then begin if GCadForm <> nil then begin if GCadForm.PCad.Selection.Count > 1 then begin SelList := TList.Create; for i := 0 to GCadForm.PCad.Selection.Count - 1 do begin CurrFigure := TFigure(GCadForm.PCad.Selection[i]); if currFigure.ID <> ARoomID then begin if CurrFigure.ClassName = ApplyClassName then begin SelCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrFigure.ID); if SelCatalog <> nil then if SelList.IndexOf(SelCatalog) = -1 then SelList.Add(SelCatalog); end; end; end; end; end; if SelList = nil then begin Result := True; exit; end; end else // Для всех на листе if F_ProjMan.F_ObjectParams.cbApplyByList.Checked then begin if GCadForm <> nil then begin SelList := TList.Create; for I := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).ClassName = ApplyClassName then begin CurrFigure := TFigure(GCadForm.FSCSFigures[i]); SelCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrFigure.ID); if SelCatalog <> nil then if SelList.IndexOf(SelCatalog) = -1 then SelList.Add(SelCatalog); end; end; end; if SelList = nil then begin Result := True; exit; end; end; { else // Для всех на проекте if F_ProjMan.F_ObjectParams.cbApplyByProj.Checked then begin for i := 0 to F_ProjMan.GSCSBase.CurrProject.ChildCatalogs.Count - 1 do begin end; end; } end; Procedure ApplyCabinetParams(aCatalog: TSCSCatalog); var i: integer; NewParams, SavedParams: TObjectParams; CabinetFig: Tfigure; begin NewParams := aCatalog.GetObjectParams; vList := GetListByID(aCatalog.ListID); if vList <> nil then begin CabinetFig := FindCabinetBySCSID(vList, NewParams.ID); if CabinetFig <> nil then begin if (CheckFigureByClassName(CabinetFig, 'TCabinet')) then begin TCabinet(CabinetFig).CabinetConfig.PointCount := TCabinet(CabinetFig).PointCount; NewParams.CabinetConfig := TCabinet(CabinetFig).CabinetConfig; end else if (CheckFigureByClassName(Cabinet, 'TCabinetExt')) then begin TCabinetExt(CabinetFig).CabinetConfig.PointCount := TCabinetExt(CabinetFig).PointCount; NewParams.CabinetConfig := TCabinetExt(CabinetFig).CabinetConfig; end; SavedParams := NewParams; if F_ProjMan.F_ObjectParams.cbDesignation.Checked then //обозначение NewParams.NameShort := ObjectParams.NameShort; if F_ProjMan.F_ObjectParams.cbDesignPos.Checked then // позиция обозначения NewParams.CabinetConfig.CabinetSignPos := ObjectParams.CabinetConfig.CabinetSignPos; if F_ProjMan.F_ObjectParams.cbNumPos.Checked then // позиция номера NewParams.CabinetConfig.CabinetNumPos := ObjectParams.CabinetConfig.CabinetNumPos; if F_ProjMan.F_ObjectParams.cbFontSize.Checked then // рамер шрифта для номера кабинета NewParams.CabinetConfig.NumRadius := ObjectParams.CabinetConfig.NumRadius; if F_ProjMan.F_ObjectParams.cbCeilingHeightCopy.Checked then // высота фальш-потолка NewParams.HeightCeiling := ObjectParams.HeightCeiling; if F_ProjMan.F_ObjectParams.cbCabinetCopy.Checked then //кабинет(галочка) NewParams.CabinetConfig.aWorkRoom := ObjectParams.CabinetConfig.aWorkRoom; if F_ProjMan.F_ObjectParams.cbAreaCopy.Checked then // спец область NewParams.CabinetConfig.aPlenumArea := ObjectParams.CabinetConfig.aPlenumArea; if F_ProjMan.F_ObjectParams.cbTabooAreaCopy.Checked then // запрещенная область NewParams.CabinetConfig.aUnroutableArea := ObjectParams.CabinetConfig.aUnroutableArea; SaveObjectParams(SCSCatalog, NewParams); ChangeCabinetParams(SCSCatalog.ListID, NewParams); // Учесть изменения для маркировок if ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTemplate) and (SavedParams.MarkID <> NewParams.MarkID) or (SavedParams.NameShort <> NewParams.NameShort)) or ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTIAEIA606A) and (SavedParams.NameShort <> NewParams.NameShort)) then begin for i := 0 to SCSCatalog.ChildCatalogReferences.Count - 1 do begin SCSObject := aCatalog.ChildCatalogReferences[i]; if IsSCSObjectItemType(SCSObject.ItemType) then RemarkObjectComponsAfterChangeRoom(SCSObject); end; end; end; end; end; // begin SavedGCadForm := GCadForm; //Tolik 20/01/2021 RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try SelList := nil; isUserSquare := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferences(ARoomID); if Assigned(SCSCatalog) then begin SCSList := SCSCatalog.GetListOwner; //ObjectParams.MarkID := SCSCatalog.MarkID; //ObjectParams.Name := SCSCatalog.Name; ObjectParams := SCSCatalog.GetObjectParams; vList := GetListByID(SCSCatalog.ListID); //Подтягиваем галочки******************************** if vList <> nil then Cabinet := FindCabinetBySCSID(vList, ObjectParams.ID); if (CheckFigureByClassName(Cabinet, 'TCabinet')) then begin TCabinet(Cabinet).CabinetConfig.PointCount := TCabinet(Cabinet).PointCount; ObjectParams.CabinetConfig := TCabinet(Cabinet).CabinetConfig; //Tolik if TCabinet(Cabinet).FCabinetSquare <> -1 then isUserSquare := True; ApplyClassName := 'TCabinet'; //16/09/2020 -- // end else if (CheckFigureByClassName(Cabinet, 'TCabinetExt')) then begin TCabinetExt(Cabinet).CabinetConfig.PointCount := TCabinetExt(Cabinet).PointCount; ObjectParams.CabinetConfig := TCabinetExt(Cabinet).CabinetConfig; //Tolik if TCabinetExt(Cabinet).FCabinetSquare <> -1 then isUserSquare := True; ApplyClassName := 'TCabinetExt'; //16/09/2020 // end; OldObjectParams := ObjectParams; if F_ProjMan.CreateFObjectParams.MakeEditRoom(meEdit, ObjectParams, SCSList, isUserSquare) then begin if CheckisSimple then begin SaveListToUndoStack(SCSList.CurrID); SaveObjectParams(SCSCatalog, ObjectParams); ChangeCabinetParams(SCSCatalog.ListID, ObjectParams); // Учесть изменения для маркировок if ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTemplate) and (OldObjectParams.MarkID <> ObjectParams.MarkID) or (OldObjectParams.NameShort <> ObjectParams.NameShort)) or ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTIAEIA606A) and (OldObjectParams.NameShort <> ObjectParams.NameShort)) then begin for i := 0 to SCSCatalog.ChildCatalogReferences.Count - 1 do begin SCSObject := SCSCatalog.ChildCatalogReferences[i]; if IsSCSObjectItemType(SCSObject.ItemType) then RemarkObjectComponsAfterChangeRoom(SCSObject); end; end; {SCSCatalog.MarkID := ObjectParams.MarkID; SCSCatalog.Name := ObjectParams.Name; SCSCatalog.Save; if Assigned(SCSCatalog.TreeViewNode) then SCSCatalog.TreeViewNode.Text := F_ProjMan.GetNameNode(SCSCatalog.TreeViewNode, SCSCatalog, true, true); } end else // Tolik 16/09/2020 -- begin // а для выбранных - в зависимости от условий - только по выбранным галочкам // По выбранным или по листу if (F_ProjMan.F_ObjectParams.cbApplySelected.Checked or F_ProjMan.F_ObjectParams.cbApplyByList.Checked) then // применить к выбранным begin SaveListToUndoStack(SCSList.CurrID); // Для текущего кабинета - принять все изменения, что сделаны.... SaveObjectParams(SCSCatalog, ObjectParams); ChangeCabinetParams(SCSCatalog.ListID, ObjectParams); // Учесть изменения для маркировок if ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTemplate) and (OldObjectParams.MarkID <> ObjectParams.MarkID) or (OldObjectParams.NameShort <> ObjectParams.NameShort)) or ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTIAEIA606A) and (OldObjectParams.NameShort <> ObjectParams.NameShort)) then begin for i := 0 to SCSCatalog.ChildCatalogReferences.Count - 1 do begin SCSObject := SCSCatalog.ChildCatalogReferences[i]; if IsSCSObjectItemType(SCSObject.ItemType) then RemarkObjectComponsAfterChangeRoom(SCSObject); end; end; //по списку for j := 0 to SelList.Count - 1 do begin SCSCatalog := TSCSCatalog(SelList[j]); ApplyCabinetParams(SCSCatalog); end; end else if F_ProjMan.F_ObjectParams.cbApplyByProj.Checked then // для всех на проекте begin SaveCurrProjectToUndoStack; // Для текущего кабинета - принять все изменения, что сделаны.... SaveObjectParams(SCSCatalog, ObjectParams); ChangeCabinetParams(SCSCatalog.ListID, ObjectParams); // Учесть изменения для маркировок if ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTemplate) and (OldObjectParams.MarkID <> ObjectParams.MarkID) or (OldObjectParams.NameShort <> ObjectParams.NameShort)) or ((F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode = mmTIAEIA606A) and (OldObjectParams.NameShort <> ObjectParams.NameShort)) then begin for i := 0 to SCSCatalog.ChildCatalogReferences.Count - 1 do begin SCSObject := SCSCatalog.ChildCatalogReferences[i]; if IsSCSObjectItemType(SCSObject.ItemType) then RemarkObjectComponsAfterChangeRoom(SCSObject); end; end; if SelList = nil then selList := TList.Create; for i := 0 to F_ProjMan.GSCSBase.CurrProject.ChildCatalogs.Count - 1 do begin ListCatalog := TSCSCatalog(F_ProjMan.GSCSBase.CurrProject.ChildCatalogs[i]); if ListCatalog.ItemType = itList then if TSCSList(ListCatalog).Setting.ListType = lt_Normal then begin selList.Clear; //GCadForm := GetListByID(ListCatalog.ListID); vList := GetListByID(ListCatalog.ListID); if vList <> nil then begin for j := 0 to vList.FSCSFigures.Count - 1 do begin if TFigure(vList.FSCSFigures[j]).ClassName = ApplyClassName then //SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.FSCSFigures[j]).ID); SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(TFigure(VList.FSCSFigures[j]).ID); if SCSCatalog <> nil then if SelList.IndexOf(SCSCatalog) = -1 then SelList.Add(SCSCatalog); end; end; //по списку for j := 0 to SelList.Count - 1 do begin SCSCatalog := TSCSCatalog(SelList[j]); ApplyCabinetParams(SCSCatalog); end; end; end; end end; end; end; except on E: Exception do AddExceptionToLog('ShowRoomProps: '+E.Message); end; GCadForm := SavedGCadForm; // Tolik 20/01/2021 -- GCanRefreshCad := RefreshFlag; RefreshCad(GCadForm.PCad); // if SelList <> nil then SelList.Free; end; procedure ShowRoomPropsInCAD(AListID, ARoomID: Integer); var SCSList: TSCSList; RoomObject: TSCSCatalog; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin RoomObject := SCSList.GetCatalogFromReferencesBySCSID(ARoomID); if RoomObject <> nil then ShowRoomProps(RoomObject.ID); end; end; { //##### получить маркировку для объекта на КАДе ##### Function GetFigureMarking(AID_Figure: Integer): string; var SCSObject: TSCSCatalog; SCSComponent: TSCSComponent; NameWithMark: String; KolvoCable: Integer; i: Integer; begin Result := ''; try SCSObject := TSCSCatalog.Create(TForm(F_ProjMan)); try SCSObject.LoadCatalogByIDFigure(AID_Figure, false, false); if SCSObject.ItemType <> itSCSLine then Exit; ///// EXIT ///// NameWithMark := SCSObject.Name + ' ' + SCSObject.NameMark; //*** Определить количество компонентов кабелей SCSObject.LoadAllComponents(SCSObject.ID, false); KolvoCable := 0; for i := 0 to SCSObject.SCSComponents.Count - 1 do begin SCSComponent := SCSObject.SCSComponents[i]; if SCSComponent.ID_ComponentType = ctCable then KolvoCable := KolvoCable + 1; end; Result := NameWithMark + ' x' + IntToStr(KolvoCable); finally FreeAndNil(SCSObject); end; except on E: Exception do AddExceptionToLog('GetFigureMarking: '+E.Message); end; end; } // ##### Вернет Список наименований компонентов объекта ##### function GetFigureComponNames(AIDFigure: integer): TStringList; var IDCat: Integer; ResList: TStringlist; SCSObject: TSCSCatalog; Compon1: TSCSComponent; Compon2: TSCSComponent; i, j: Integer; ExemplarKolvo: integer; ListWithLooked: TIntList; //ptrID: ^Integer; CanHintCompon: Boolean; //25.06.2013 JackCount, BusyCount, EmptyCount: Integer; FillObj: TFillConnectConObj; k, jj, kk: integer; Interf: TSCSInterface; PortInterf: TSCSInterface; busyexist: boolean; PortInterfRel: PPortInterfRel; Capacity: integer; BusyKoef: double; begin Result := nil; try ResList := nil; with F_ProjMan.DM do begin ListWithlooked := TIntList.Create; SCSObject := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Not Assigned(SCSObject) then Exit; ///// EXIT ///// ResList := TStringList.Create; //if SCSObject. for i := 0 to SCSObject.SCSComponents.Count - 1 do begin Compon1 := SCSObject.SCSComponents[i]; if Assigned(Compon1) then begin CanHintCompon := false; case SCSObject.ItemType of itSCSConnector: CanHintCompon := true; itSCSLine: if Compon1.ComponentType.SysName = ctsnCableChannel then CanHintCompon := true; end; if CanHintCompon and (ListWithLooked.IndexOf(Compon1.ID) = -1) {CheckNoIDinList(Compon1.ID, ListWithLooked)} then begin //*** подсчитать количество компонент даного оьразца ExemplarKolvo := 0; for j := 0 to SCSObject.SCSComponents.Count - 1 do begin Compon2 := SCSObject.SCSComponents[j]; if Assigned(Compon2) then if (Compon1.Name = Compon2.Name) and (Compon1.GuidNB = Compon2.GuidNB) then begin ExemplarKolvo := ExemplarKolvo + 1; ListWithLooked.Add(Compon2.ID); end; end; if ExemplarKolvo <= 1 then ResList.Add(Compon1.Name); if ExemplarKolvo > 1 then ResList.Add(Compon1.Name + ' x' + IntToStr(ExemplarKolvo)); end; end; end; //25.06.2013 - в хинт віводим сколько разїемов занято/свободно if SCSObject.ItemType = itSCSConnector then begin JackCount := 0; BusyCount := 0; EmptyCount := 0; for i := 0 to SCSObject.ComponentReferences.Count - 1 do begin Compon1 := SCSObject.ComponentReferences[i]; if (Compon1.ComponentType.SysName = ctsnWorkPlace) or ((Compon1.ComponentType.SysName = ctsnPatchPanel) and (Compon1.ChildReferences.Count = 0)) or (GCompTypeSysNameModules.IndexOf(Compon1.ComponentType.SysName) <> -1) then begin { FillObj := Compon1.GetFilling(biNone, itFunctional, false, true); if (FillObj = foBusy) or (FillObj = foPartEmpty) then begin Inc(JackCount); Inc(BusyCount); end else if FillObj = foEmpty then begin Inc(JackCount); Inc(EmptyCount); end; } for jj := 0 to Compon1.Interfaces.Count - 1 do begin Interf := Compon1.Interfaces[jj]; if (Interf.IsPort = biTrue) then if (Interf.TypeI = itFunctional) then begin if Interf.ID_Component = Compon1.ID then begin if Interf.PortInterfaces.Count > 0 then begin busyexist := False; for kk := 0 to Interf.PortInterfaces.Count - 1 do begin PortInterf := Interf.PortInterfaces[kk]; if (PortInterf.IsBusy = biTrue) or (PortInterf.KolvoBusy > 0) then begin busyexist := True; break; end; end; if busyexist then begin JackCount := JackCount + Interf.Kolvo; if PortInterf.Kolvo <> 0 then BusyKoef := PortInterf.KolvoBusy / PortInterf.Kolvo else BusyKoef := 1; BusyCount := BusyCount + Round(Interf.Kolvo * BusyKoef); EmptyCount := EmptyCount + (Interf.Kolvo - Round(Interf.Kolvo * BusyKoef)); {Capacity := 0; for k := 0 to Interf.PortInterfRels - 1 do begin PortInterfRel := Interf.PortInterfRels.List^[k]; if PortInterfRel.IDInterface = PortInterf.ID then begin Capacity := PortInterfRel.UnitInterfKolvo; break; end; end; if Capacity = 0 then begin ... end else begin ... добавить с учетом capacity интерфейсов. end; } end else begin JackCount := JackCount + Interf.Kolvo; EmptyCount := EmptyCount + Interf.Kolvo; end; end; end; end; end; end; end; if JackCount > 0 then begin ResList.Add(cBaseCommon84_1+': '+IntToStr(JackCount)); ResList.Add(cBaseCommon84_2+': '+IntToStr(BusyCount)); ResList.Add(cBaseCommon84_3+': '+IntToStr(EmptyCount)); end; end; Result := ResList; { IDCat := GetIDCatalogByIDFigure(AIDFigure); ResList := TStringList.Create; SetSQLToQuery(scsQSelect, ' select name from component, catalog_relation '+ ' where (id = id_component) and (id_catalog = '''+IntTostr(IDCat)+''') '); while Not scsQSelect.Eof do begin ResList.Add(scsQSelect.FN('Name').AsString); scsQSelect.Next; end; Result := ResList; } //finally ListWithlooked.Free; //FreeList(ListWithlooked); //SCSObject.Free; //end; end; except on E: Exception do AddExceptionToLog('GetFigureComponNames: '+E.Message); end; end; // ##### Формирует структурированную выноску для объекта ##### function GetObjectStructuredNotes(AObject: TObject): TStringList; const cTab = 3; var ResList: TStringList; ListWithComplNotes: TStringList; ListWithoutComplNotes: TStringList; StringList: TStringList; List: TSCSList; GroupName: String; SCSObject: TSCSCatalog; i, j: Integer; Compon: TSCSComponent; ChildCompon: TSCSComponent; ListWithLookedID: TIntList; function GetSiblingComponsCount(ACompon: TSCSComponent; ASiblingComponents: TSCSComponents; AWitNoCompl: Boolean): String; var CheckCompon: TSCSComponent; i, j: Integer; ExemplarKolvo: Integer; PrefixName: String; begin Result := ''; if (ACompon = nil) or (ASiblingComponents = nil) then Exit; //// EXIT //// ExemplarKolvo := 0; if ACompon.KolComplect = 0 then for i := 0 to ASiblingComponents.Count - 1 do if Assigned(ASiblingComponents[i]) then begin CheckCompon := ASiblingComponents[i]; if (ListWithLookedID.IndexOf(CheckCompon.ID) = -1) and (CheckCompon.IsDismount = biFalse) {CheckNoIDinList(CheckCompon.ID, ListWithLookedID)} then begin if //(ACompon.ID <> ptrCheckCompon.ID) and (ACompon.Name = CheckCompon.Name) and (ACompon.GuidNB = CheckCompon.GuidNB) then if ((AWitNoCompl) and (CheckCompon.KolComplect = 0)) or (AWitNoCompl <> true) then begin ExemplarKolvo := ExemplarKolvo + 1; ListWithLookedID.Add(CheckCompon.ID); end; end; end else if ACompon.IsDismount = biFalse then begin ExemplarKolvo := 1; ListWithLookedID.Add(ACompon.ID); end; PrefixName := ''; if Assigned(List) then PrefixName := List.Setting.NoteCountPrefix else PrefixName := 'x'; Result := GetPrefixCountByType(ACompon.Name, PrefixName, ExemplarKolvo, List.Setting.PrefixCountType); if Result = '' then Result := ACompon.Name; //if ExemplarKolvo <= 1 then // Result := ACompon.Name; //if ExemplarKolvo > 1 then // Result := ACompon.Name +PrefixName+ IntToStr(ExemplarKolvo); end; procedure Step(AComponents: TSCSComponents; AStepNum: Integer; AMainStrList: TStringList); var LWithComplNotes: TStringList; LWithoutComplNotes: TStringList; Compon: TSCSComponent; i: Integer; strTab: String; SiblingComponsCount: String; begin if AComponents.Count > 0 then begin strTab := ''; StrTab := DupStr(' ', AStepNum); LWithComplNotes := TStringList.Create; LWithoutComplNotes := TStringList.Create; for i := 0 to AComponents.Count - 1 do begin Compon := AComponents[i]; if ListWithLookedID.IndexOf(Compon.ID) = -1 then if (Compon.ComponentType.SysName <> ctsnCableChannel) or (List.Setting.CADNotesKind = skDetail) then begin //*** Лист без комплектующих if Compon.KolComplect = 0 then begin SiblingComponsCount := GetSiblingComponsCount(Compon, AComponents, true); //if SiblingComponsCount <> '' then begin GroupName := strTab + SiblingComponsCount; LWithoutComplNotes.Add(GroupName); end; end; //*** Лист с комплектующими if Compon.KolComplect > 0 then begin SiblingComponsCount := GetSiblingComponsCount(Compon, AComponents, false); //if SiblingComponsCount <> '' then begin GroupName := strTab + SiblingComponsCount; LWithComplNotes.Add(GroupName); //*** Загрузка имен комплектующих Step(Compon.ChildComplects, AStepNum + cTab, LWithComplNotes); end; //else // //*** Загрузка имен комплектующих // Step(Compon.ChildComplects, AStepNum, LWithComplNotes); end; end else //*** Загрузка имен комплектующих if Compon.KolComplect > 0 then Step(Compon.ChildComplects, AStepNum, LWithComplNotes); end; AMainStrList.AddStrings(LWithComplNotes); AMainStrList.AddStrings(LWithoutComplNotes); FreeAndNil(LWithComplNotes); FreeAndNil(LWithoutComplNotes); end; end; begin Result := nil; List := nil; if AObject = nil then Exit; ///// EXIT /////s try ResList := TStringList.Create; //ListWithComplNotes := TStringList.Create; //ListWithoutComplNotes := TStringList.Create; //StringList := TStringList.Create; // Tolik 14/06/2018 -- не используется. но и не сбрасывается..нах нужно? ListWithLookedID := TIntList.Create; try SCSObject := TSCSCatalog(AObject); List := SCSObject.GetListOwner; //Step(SCSObject.SCSComponents, 0, ListWithComplNotes); Step(SCSObject.SCSComponents, 0, ResList); //ResList.AddStrings(ListWithComplNotes); Result := ResList; finally //FreeAndNil(ListWithComplNotes); //FreeAndNil(ListWithoutComplNotes); ListWithLookedID.Free; end; except on E: Exception do AddExceptionToLog('GetFigureNote: '+E.Message); end; end; // ##### Формирует выноски на КАД ##### function GetObjectNotesByMarkStr(AObject: TObject; AShowType: TShowType): TStringList; var i, j: Integer; LookedCompons: TSCSComponents; List: TSCSList; SCSObject: TSCSCatalog; SCSComponent: TSCSComponent; CurrCompon: TSCSComponent; MarkCount: Integer; GroupCount: Integer; PrefixName: String; function CheckNoInLooked(AComponent: TSCSComponent): Boolean; var i: Integer; ComponLooked: TSCSComponent; begin Result := true; for i := 0 to LookedCompons.Count - 1 do begin ComponLooked := LookedCompons[i]; if ComponLooked.IsDismount = biFalse then if ComponLooked.NameShort = AComponent.NameShort then if ComponLooked.CheckCmpByInterfaces(AComponent) then begin Result := false; Break; ///// BREAK ////// end; end; end; begin Result := nil; SCSObject := TSCSCatalog(AObject); GroupCount := 0; if Assigned(SCSObject) then begin List := SCSObject.GetListOwner; if Assigned(List) then PrefixName := List.Setting.NoteCountPrefix else PrefixName := 'x'; Result := TStringList.Create; LookedCompons := TSCSComponents.Create(false); for i := 0 to SCSObject.ComponentReferences.Count - 1 do begin SCSComponent := SCSObject.ComponentReferences[i]; MarkCount := 0; if Assigned(SCSComponent) and ((List.Setting.CADNotesKind = skDetail) or (SCSComponent.ComponentType.SysName <> ctsnCableChannel)) then if SCSComponent.NameShort <> '' then if CheckNoInLooked(SCSComponent) then begin for j := 0 to SCSObject.ComponentReferences.Count - 1 do begin CurrCompon := SCSObject.ComponentReferences[j]; if Assigned(CurrCompon) then if CurrCompon.NameShort = SCSComponent.NameShort then if CurrCompon.CheckCmpByInterfaces(SCSComponent) then Inc(MarkCount); end; GroupCount := GroupCount + MarkCount; if MarkCount > 0 then Result.Add(GetPrefixCountByType(SCSComponent.NameShort, PrefixName, MarkCount, List.Setting.PrefixCountType)); //Result.Add(SCSComponent.NameShort +PrefixName+ IntToStr(MarkCount)); //case AShowType of // st_Full: // Result.Add(SCSComponent.NameShort +PrefixName+ IntToStr(MarkCount)); // //st_Short: // // Result.Add(PrefixName + IntToStr(MarkCount)); //end; LookedCompons.Add(SCSComponent); end; end; //if AShowType = st_Short then // Result.Add(IntToStr(GroupCount)); FreeAndNil(LookedCompons); end; end; function GetObjectNotesWithParams(AIDFigure: Integer): TStringList; var SCSObject: TSCSCatalog; begin Result := nil; SCSObject := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then Result := GetObjectNotes(SCSObject); end; function GetObjectNotes(AObject: TObject): TStringList; var List: TSCSList; begin Result := nil; List := TSCSCatalog(AObject).GetListOwner; if List <> nil then case List.Setting.CADShowObjectNotesType of st_Short: Result := GetObjectNotesByMarkStr(AObject, List.Setting.CADShowObjectNotesType); st_Full: Result := GetObjectStructuredNotes(AObject); end; end; function GetObjectPortMultyPortNameMarks(AObject: TObject): TStringList; var SCSObject: TSCSCatalog; i: Integer; SCSComponent: TSCSComponent; ComponNameMarks: TStringList; begin Result := nil; SCSObject := nil; SCSObject := TSCSCatalog(AObject); if Assigned(SCSObject) then begin Result := TStringList.Create; for i := 0 to SCSObject.SCSComponents.Count - 1 do begin SCSComponent := SCSObject.SCSComponents[i]; if Assigned(SCSComponent) then begin ComponNameMarks := SCSComponent.GetPortMultiPortNameMarks; if Assigned(ComponNameMarks) then begin Result.Text := Result.Text + ComponNameMarks.Text; FreeAndNil(ComponNameMarks); end; end; end; //*** Если ничего не найдено, берем маркировку первой компоненты if Result.Text = '' then if SCSObject.SCSComponents.Count > 0 then begin SCSComponent := SCSObject.SCSComponents[0]; if Assigned(SCSComponent) then begin ComponNameMarks := SCSComponent.GetPortMultiPortNameMarks; if Assigned(ComponNameMarks) then begin Result.Text := Result.Text + ComponNameMarks.Text; FreeAndNil(ComponNameMarks); end; end; end; //*** Если в объкте нихрена нету, то берем маркировку объекта //if Result = '' then // Result := SCSObject.Name + SCSObject.NameMark; end; end; // ##### Определяет имя объекта на КАд ##### Function GetFullNameWithOptions(AID_Figure: Integer; AShowNameType: TShowType): string; var IDCat: Integer; SCSObject: TSCSCatalog; begin try Result := ''; with F_ProjMan do begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AID_Figure); if Assigned(SCSObject) then if SCSObject.IsUserName = biFalse then Result := GetNameAndIndex(SCSObject.Name, SCSObject.ItemType, SCSObject.IndexPointObj, SCSObject.IndexConnector, SCSObject.IndexLine) //case AShowNameType of // st_Full: // Result := SCSObject.Name + SCSObject.NameMark; // //Result := GetObjectPortMultyPortNameMarks(SCSObject); // st_Short: // Result := GetNameAndIndex(SCSObject.Name, SCSObject.ItemType, SCSObject.IndexPointObj, // SCSObject.IndexConnector, // SCSObject.IndexLine); //end else Result := SCSObject.Name; end; except on E: Exception do AddExceptionToLog('GetFullNameWithOptions: '+E.Message); end; end; { function GetFigureIndex(AIDFigure: Integer): Integer; var IDCat: Integer; Catalog: TCatalog; begin Result := 0; try IDCat := F_ProjMan.DM.GetIDCatalogByIDFigure(AIDFigure); Catalog := F_ProjMan.DM.GetCatalogByID(IDCat, qmMemory); if Catalog.IndexPointObj > 0 then Result := Catalog.IndexPointObj; if Catalog.IndexConnector > 0 then Result := Catalog.IndexConnector; if Catalog.IndexLine > 0 then Result := Catalog.IndexLine; except on E: Exception do AddExceptionToLog('GetFigureIndex: '+E.Message); end; end; } function GetFigureFirstComponentName(AIDFigure: Integer): string; var SCSObject: TSCSCatalog; FirstComponent: TSCSComponent; begin Result := ''; with F_ProjMan do begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then begin FirstComponent := SCSObject.GetFirstComponent; if Assigned(FirstComponent) then Result := FirstComponent.GetNameForVisible(false); end; end; end; procedure ReDefineObjectComponsNameMarks(AObject: TObject); var SCSCatalog: TSCSCatalog; begin SCSCatalog := TSCSCatalog(AObject); SCSCatalog.NameMark := TF_Main(SCSCatalog.ActiveForm).MakeNameMarkCatalog(SCSCatalog.ID, false, qmMemory); SCSCatalog.DefineComponsNameMarks; F_ProjMan.F_ChoiceConnectSide.DefineObjectSignature(SCSCatalog); if Assigned(SCSCatalog.TreeViewNode) then SCSCatalog.TreeViewNode.Text := SCSCatalog.GetNameForVisible(true); end; { // ##### Формирует выноску для объекта ##### function GetFigureNote(AIDFigure: Integer): TStringList; var ResList: TStringList; ListWithComplNotes: TStringList; ListWithoutComplNotes: TStringList; StringList: TStringList; GroupName: String; SCSObject: TSCSCatalog; i, j: Integer; ptrCompon: PSCSComponent; ptrChildCompon: PSCSComponent; ListWithLookedID: TList; function GetListComponNames(ACompon: TSCSComponent; AComponents: TList; AWitNoCompl: Boolean): String; var //ptrSCSCompon: PSCSComponent; ptrCheckCompon: PSCSComponent; i, j: Integer; ExemplarKolvo: Integer; LookedID: TList; ptrID: ^Integer; begin Result := ''; if (ACompon = nil) or (AComponents = nil) then Exit; //// EXIT //// //LookedID := TList.Create; ExemplarKolvo := 0; if ACompon.KolComplect = 0 then for i := 0 to AComponents.Count - 1 do begin ptrCheckCompon := AComponents[i]; if CheckNoIDinList(ptrCheckCompon.ID, ListWithLookedID) then begin if //(ACompon.ID <> ptrCheckCompon.ID) and (ACompon.Name = ptrCheckCompon.Name) and (ACompon.IDNormBase = ptrCheckCompon.IDNormBase) then if ((AWitNoCompl) and (ptrCheckCompon.KolComplect = 0)) or (AWitNoCompl <> true) then begin ExemplarKolvo := ExemplarKolvo + 1; New(ptrID); ptrID^ := ptrCheckCompon.ID; ListWithLookedID.Add(ptrID); end; end; end else begin ExemplarKolvo := 1; New(ptrID); ptrID^ := ACompon.ID; ListWithLookedID.Add(ptrID); end; if ExemplarKolvo <= 1 then Result := ACompon.Name; if ExemplarKolvo > 1 then Result := ACompon.Name +' x'+ IntToStr(ExemplarKolvo); //FreeList(LookedID); end; begin try try Result := nil; ResList := TStringList.Create; ListWithComplNotes := TStringList.Create; ListWithoutComplNotes := TStringList.Create; StringList := TStringList.Create; SCSObject := TSCSCatalog.Create(TForm(F_ProjMan)); SCSObject.LoadCatalogByIDFigure(AIDFigure, false, false); SCSObject.LoadComponents(SCSObject.ID, false); ListWithLookedID := TList.Create; //*** Загрузка компонентов в которых нет комплектующих for i := 0 to SCSObject.SCSComponents.Count - 1 do begin ptrCompon := SCSObject.SCSComponents[i]; if CheckNoIDinList(ptrCompon.ID, ListWithLookedID) then begin //*** Лист без комплектующих if ptrCompon.KolComplect = 0 then begin GroupName := GetListComponNames(ptrCompon^, SCSObject.SCSComponents, true); ListWithoutComplNotes.Add(GroupName); end; //*** Лист с комплектующими if ptrCompon.KolComplect > 0 then begin GroupName := GetListComponNames(ptrCompon^, SCSObject.SCSComponents, false); ListWithComplNotes.Add(GroupName); //*** Загрузка имен комплектующих ptrCompon.LoadChildComplects(false); for j := 0 to ptrCompon.ChildComplects.Count - 1 do begin ptrChildCompon := ptrCompon.ChildComplects[j]; if CheckNoIDinList(ptrChildCompon.ID, ListWithLookedID) then begin GroupName := GetListComponNames(ptrChildCompon^, ptrCompon.ChildComplects, false); ListWithComplNotes.Add(' ' + GroupName); end; end; end; end; end; ResList.AddStrings(ListWithoutComplNotes); ResList.AddStrings(ListWithComplNotes); Result := ResList; except on E: Exception do AddExceptionToLog('GetFigureNote: '+E.Message); end; finally ListWithComplNotes.Free; ListWithoutComplNotes.Free; SCSObject.Free; FreeList(ListWithLookedID); end; end;} procedure SaveFigureParams(AIDFigure: Integer; AFigureParams: TObjectParams); var SCSCatalog: TSCSCatalog; begin SCSCatalog := nil; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSCatalog) then begin SaveObjectParams(SCSCatalog, AFigureParams); end; end; procedure SaveObjectParams(AObject: TObject; AFigureParams: TObjectParams); var SCSCatalog: TSCSCatalog; OldParams: TObjectParams; VariosParams: Boolean; i: integer; begin SCSCatalog := TSCSCatalog(AObject); OldParams := SCSCatalog.GetObjectParams; if SCSCatalog.IndexConnector <> 0 then SCSCatalog.IndexConnector := AFigureParams.MarkID; if SCSCatalog.IndexPointObj <> 0 then SCSCatalog.IndexPointObj := AFigureParams.MarkID; if SCSCatalog.IndexLine <> 0 then SCSCatalog.IndexLine := AFigureParams.MarkID; SCSCatalog.Name := AFigureParams.Name; SCSCatalog.MarkID := AFigureParams.MarkID; SCSCatalog.IsIndexWithName := AFigureParams.IndexWithName; if SCSCatalog.ItemType = itRoom then begin SCSCatalog.NameShort := AFigureParams.NameShort; if SCSCatalog.RoomSetting <> nil then begin VariosParams := false; if SCSCatalog.RoomSetting.HeightCeiling <> AFigureParams.HeightCeiling then VariosParams := true; SCSCatalog.RoomSetting.HeightCeiling := AFigureParams.HeightCeiling; if VariosParams then for i := 0 to SCSCatalog.ChildCatalogReferences.Count - 1 do F_ProjMan.F_ChoiceConnectSide.DefineObjectParamsInFuture(SCSCatalog.ChildCatalogReferences[i]); end; end; SCSCatalog.Save; if (OldParams.MarkID <> AFigureParams.MarkID) or (OldParams.IndexWithName <> AFigureParams.IndexWithName) or (OldParams.NameShort <> AFigureParams.NameShort) then ReDefineObjectComponsNameMarks(SCSCatalog); if Assigned(SCSCatalog.TreeViewNode) then SCSCatalog.TreeViewNode.Text := SCSCatalog.GetNameForVisible(true); end; // Tolik 07/11/2018 -- вынесена в U_Common { 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; } { function GetFigureParams(AIDFigure: Integer): TObjectParams; var SCSCatalog: TSCSCatalog; begin ZeroMemory(@Result, SizeOf(TObjectParams)); SCSCatalog := nil; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSCatalog) then begin Result := SCSCatalog.GetObjectParams; end; end; } // procedure SaveCADListParams(AIDList: Integer; AListParams: TListParams); var SCSList: TSCSList; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then SCSList.AssignSettings(AListParams.Settings); end; procedure SaveListParams(AIDList: Integer; AListParams: TListParams; AForAllObjects: Boolean = true; AForSelectedobject: Boolean = true); //const CmpDelta = 0.0001; var ListSettings: TListSettingRecord; SCSList: TSCSList; ProjList: TSCSList; SaveRes: Boolean; ListNode: TTreeNode; //IDListCatalog: Integer; OldSettings: TListSettingRecord; OldMarkID: Integer; RefreshListType: Integer; i: Integer; SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; SavedExpanded: Boolean; begin try SaveRes := false; SCSList := nil; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); ListNode := nil; RefreshListType := rltNone; ListSettings := AListParams.Settings; if SCSList = nil then begin SCSList := TSCSList.Create(TForm(F_ProjMan)); SCSList.Open(AIDList); //SCSList.CurrID := AIDList; OldSettings := SCSList.Setting; OldMarkID := SCSList.MarkID; SCSList.Setting := ListSettings; SCSList.Save; SaveRes := true; FreeAndNil(SCSList); end else begin OldSettings := SCSList.Setting; OldMarkID := SCSList.MarkID; SCSList.Setting := ListSettings; SCSList.Save; SaveRes := true; end; if SaveRes then with F_ProjMan do begin ProjList := GSCSBase.CurrProject.GetListBySCSID(AIDList); if ProjList <> nil then begin ProjList.Setting := ListSettings; if OldMarkID <> AListParams.MarkID then begin ProjList.MarkID := AListParams.MarkID; ProjList.Save; if Assigned(ProjList.TreeViewNode) then ProjList.TreeViewNode.Text := ProjList.GetNameForVisible(false); end; ProjList.IsIndexWithName := AListParams.IsIndexWithName; ProjList.IndexConnector := AListParams.IndexConnector; ProjList.IndexLine := AListParams.IndexLine; ProjList.IndexPointObj := AListParams.IndexPointObj; end; //*** Обновление длин if (Abs(OldSettings.LengthKoef - ListSettings.LengthKoef) > cnstCmpLenDelta) or (Abs(OldSettings.MultiportReserv - ListSettings.MultiportReserv) > cnstCmpLenDelta) or (Abs(OldSettings.PortReserv - ListSettings.PortReserv) > cnstCmpLenDelta) then RefreshComponsLengthByList(SCSList.CurrID); //08.01.2013 Обновить свойства Листа в МП if Not CmpFloatByPrecision(OldSettings.HeightCeiling, ListSettings.HeightCeiling, 3) or Not CmpFloatByPrecision(OldSettings.HeightRoom, ListSettings.HeightRoom, 3) or Not CmpFloatByPrecision(OldSettings.HeightCorob, ListSettings.HeightCorob, 3) then RefreshListType := RefreshListType or rltTracessStyle; { if OldSettings.CADTraceStyle <> ListSettings.CADTraceStyle then RefreshListType := RefreshListType or rltTracessStyle; //IDListCatalog := DM.GetIDCatalogByIDList(AIDList); //IDListCatalog := SCSList.ID; //*** Обновить свойства Листа в МП //if (OldSettings.HeightCeiling <> ListSettings.HeightCeiling) or // (OldSettings.HeightRoom <> ListSettings.HeightRoom) or // (OldSettings.HeightCorob <> ListSettings.HeightCorob) then // begin // //SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnHeightCeiling, ListSettings.HeightCeiling, qmUndef, -1); // RefreshListType := RefreshListType or rltTracessStyle; // //RefreshListTracesStyle(SCSList.CurrID); // end; //if OldSettings.HeightCorob <> ListSettings.HeightCorob then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnHeightCorob, ListSettings.HeightCorob, qmUndef, -1); //if OldSettings.HeightRoom <> ListSettings.HeightRoom then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnHeightRoom, ListSettings.HeightRoom, qmUndef, -1); //if OldSettings.HeightSocket <> ListSettings.HeightSocket then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnHeightSocket, ListSettings.HeightSocket, qmUndef, -1); //if OldSettings.LengthKoef <> ListSettings.LengthKoef then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnLengthKoef, ListSettings.LengthKoef, qmUndef, -1); if OldSettings.CableCanalFullnessKoef <> ListSettings.CableCanalFullnessKoef then RefreshListType := RefreshListType or rltTracessFulness; //if OldSettings.PortReserv <> ListSettings.PortReserv then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnPortReserv, ListSettings.PortReserv, qmUndef, -1); //if OldSettings.MultiportReserv <> ListSettings.MultiportReserv then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnMultiPortReserv, ListSettings.MultiportReserv, qmUndef, -1); //if OldSettings.HeightSocket <> ListSettings.HeightSocket then // SetPropertyValueAsFloat(tkCatalog, SCSList.ID, pnHeightSocket, ListSettings.HeightSocket, qmUndef, -1); if (OldSettings.ShowObjectTypeCAD <> ListSettings.ShowObjectTypeCAD) then RefreshListType := RefreshListType or rltCADSignature; //*** Подписи if (OldSettings.ShowConnObjectCaption <> ListSettings.ShowConnObjectCaption) or (OldSettings.ShowLineObjectCaption <> ListSettings.ShowLineObjectCaption) or (OldSettings.ShowObjectTypeCAD <> ListSettings.ShowObjectTypeCAD) then RefreshListType := RefreshListType or rltCADSignature; //*** Выноски if (OldSettings.ShowConnObjectNote <> ListSettings.ShowConnObjectNote) or (OldSettings.ShowLineObjectNote <> ListSettings.ShowLineObjectNote) or (OldSettings.CADShowObjectNotesType <> ListSettings.CADShowObjectNotesType) then RefreshListType := RefreshListType or rltNote; } //*** Префикс количества if (OldSettings.NoteCountPrefix <> ListSettings.NoteCountPrefix) or (OldSettings.PrefixCountType <> ListSettings.PrefixCountType) then begin RefreshListType := RefreshListType or rltCADSignature; RefreshListType := RefreshListType or rltNote; end; if (RefreshListType <> rltNone) and AForAllObjects then RefreshListItems(SCSList.CurrID, RefreshListType, AForSelectedobject); if Assigned(ProjList) then ListNode := ProjList.TreeViewNode; if Not Assigned(ListNode) then ListNode := FindComponOrDirInTree(SCSList.ID, false); //*** Группаровка объектов if ListNode <> nil then begin if OldSettings.GroupListObjectsByType = ListSettings.GroupListObjectsByType then RefreshNodesText(ListNode, [itComponLine, itSCSLine, itSCSConnector]) else try LockTreeAndGrid(true); ProjList.SetItemsFTreeNodeToNil; SavedExpanded := ListNode.Expanded; DeleteChildNodes(ListNode); AddNodes(ListNode); ListNode.Expanded := SavedExpanded; finally LockTreeAndGrid(false); end; end; //*** Обновить наименования Листов с дизайном компонент, // имеющихся на текущем изменяемом листе GSCSBase.CurrProject.UpdateDesignListsNamesByOwnerList(ProjList); if SCSList <> nil then SCSList.NotifyChange; F_ProjMan.RefreshNode; end; except on E: Exception do AddExceptionToLog('SaveListParams: '+E.Message); end; end; function GetDefaultListSettings(aForNewList: Boolean; AUOM: Integer=-1): TListSettingRecord; var UOM: Integer; begin UOM := AUOM; if (UOM = -1) and Assigned(F_ProjMan) then UOM := F_ProjMan.FUOM; ZeroMemory(@Result, SizeOf(TListSettingRecord)); Result.CableCanalFullnessKoef := 50; Result.LengthKoef := 10; Result.PortReserv := 0.5; Result.MultiportReserv := 1; Result.TwistedPairMaxLength := 90; Result.CADClickObjectType := ct_Single; Result.CADBlockStep := 4; Result.CADGridStep := 1; Result.CADHeight := 210; Result.CADWidth := 297; Result.CADPageOrient := poLandscape; Result.CADPageSizeIndex := 3; Result.CADShowRaise := true; Result.CADStampType := stt_extended; {$IF Defined(SCS_PE) or Defined(SCS_SPA)} Result.CADStampLang := stl_eng; {$ELSE} Result.CADStampLang := stl_rus; {$IFEND} //Tolik 17/08/2021 -- //Result.CADFontName := 'GOST'; {$IF DEFINED(SCS_PE)} Result.CADFontName := 'Tahoma'; {$ELSE} Result.CADFontName := 'GOST'; {$IFEND} // // Result.CADTraceColor := clBlack; Result.CADTraceStyle := psSolid; Result.CADTraceWidth := 1; Result.CADShowObjectNotesType := st_Full; Result.CornerType := crn_In; Result.HeightRoom := 3.00; Result.HeightCeiling := 0.30; Result.HeightSocket := 0.3; Result.HeightCorob := 0.7; Result.ControlComplectByProducer := false; Result.ControlJoinByNetType := true; Result.GroupListObjectsByType := true; Result.KeepLineTypesRules := true; Result.NoteCountPrefix := 'x'; Result.PutCableInTrace := true; Result.ShowConnObjectCaption := true; Result.ShowConnObjectNote := false; Result.ShowLineObjectCaption := true; Result.ShowLineObjectLength := true; Result.ShowLineObjectNote := false; Result.ShowObjectTypeCAD := st_Full; Result.ShowObjectTypePM := st_Short; Result.CADShowRuler := True; Result.CADShowGrid := True; Result.CADShowGuides := True; Result.CADSnapGrid := True; Result.CADSnapGuides := True; Result.CADSnapNearObject := False; Result.ListType := lt_Normal; Result.IDFigureForDesignList := -1; Result.IDListForDesignList := -1; Result.ControlComplectByProperties := true; Result.ControlJoinByProperties := true; Result.CADCaptionsKind := skSimple; Result.CADNotesKind := skSimple; Result.UseComponTypeHeights := false; Result.CADShowCabinetsNumbers := true; Result.CADDimLinesType := dlt_None; Result.CADLinesCaptionsColor := clRed; // цвет подписей трасс Result.CADConnectorsCaptionsColor := clBlue; // цвет подписей коннекторов Result.CADLinesNotesColor := clRed; // цвет выносок трасс Result.CADConnectorsNotesColor := clBlue; // цвет выносок коннекторов Result.CADLinesCaptionsFontSize := 6; Result.CADConnectorsCaptionsFontSize := 6; Result.CADLinesNotesFontSize := 6; Result.CADConnectorsNotesFontSize := 6; Result.CADLinesCaptionsFontBold := False; Result.CADCrossATSFontSize := 6; Result.CADDistribCabFontSize := 6; Result.CADCrossATSFontBold := False; Result.CADDistribCabFontBold := False; Result.CADPrintType := pt_Black; Result.PrefixCountType := pctAfter; Result.SCSType := st_Internal; //st_NoChoose; {$IF Defined(TELECOM)} Result.SCSType := st_External; Result.CADCaptionsKind := skExternalSCS; //04.04.2011 Result.HeightCeiling := 0; Result.HeightSocket := 0; Result.HeightCorob := 0; {$IFEND} Result.ShowNameInDesignList := true; Result.ShowNameShortInDesignList := false; Result.ShowNameMarkInDesignList := false; Result.CanSetCorkBetweenTraces := false; Result.CADTraceStepRotate := 5; Result.AutoCadMouse := true; Result.ScaleByCursor := true; Result.CADAutoPosTraceBetweenRM := False; Result.CADListCountX := 1; Result.CADListCountY := 1; Result.CADShowMainStamp := true; Result.CADShowUpperStamp := true; Result.CADShowSideStamp := true; Result.CADSaveUndoCount := 1; Result.CADAllowSuppliesKind := false; Result.CADShowCabinetsBounds := false; Result.CADRuleStep := 1; // Шаг шкалы на линейке Result.CADRuleAllSize := 0; // Весь размер линейки //15.04.2011 Result.CADShowPathLengthType := Ord(sltInner); //Ord(sltPoints); // - до настроек было по типу sltPoints Result.CADShowPathTraceLengthType := Ord(sltInner); //Ord(sltInner); // - до настроек было по типу sltInner // Если щас традиц. си США, то ставим другие знач-я if CheckIsTradUOM(UOM) then //if Assigned(F_ProjMan) and CheckIsTradUOM(F_ProjMan.FUOM) then begin //Each sheet must include: //a top margin of at least 2.5 cm. (1 inch) //a left side margin of at least 2.5 cm. (1 inch) //a right side margin of at least 1.5 cm. (5/8 inch) //and a bottom margin of at least 1.0 cm. (3/8 inch) //thereby leaving a sight no greater than 17.0 cm. by 26.2 cm. on 21.0 cm. by 29.7 cm. (DIN size A4) drawing sheets //and a sight no greater than 17.6 cm. by 24.4 cm. (6 15/16 by 9 5/8 inches) on 21.6 cm. by 27.9 cm. (8 1/2 by 11 inch) drawing sheets Result.CADStampMargins := DoubleRect(25, 25, 15, 10); //11.11.2011 end else begin Result.CADStampMargins := DoubleRect(20,5,5,5); //11.11.2011 end; Result.CADStampDeveloper := ''; Result.CADStampChecker := ''; Result.CADStampListSign := ''; Result.CADStampMainEngineer := ''; Result.CADStampApproved := ''; Result.CADStampDesignStage := ''; Result.CADStampForPrinter := false; //29.11.2011 //03.08.2007 LoadDefListSettingsFromFile(Result); Result.CADGrayedColor := DefGrayedColor; Result.CADNewTraceLengthType := Ord(tltNone); Result.CADShowRaiseDrawFigure := False; Result.CableSwervesMaxCount := 10; Result.CableSwervesAngle := 90; // Tolik -- 16/09/2016 -- Result.ShowRaiseHeights := False; Result.AllowTransparency := True; // Tolik 28/06/2017 -- по умолчанию прозрачность поддерживаем...буде тормозить -- // можно отключить переключателем (кнопка на панели КАДа) //Result.ShowTracesCrossPoints := False; // -- Tolik -- 13/09/2017 -- по умолчанию пересечения трасс не показываем Result.ShowTracesCrossPoints := 0; // -- Tolik -- 13/09/2017 -- по умолчанию пересечения трасс не показываем if aForNewList then begin Result.CADNewTraceLengthType := Ord(tltAuto); if Result.SCSType = st_External then Result.CADNewTraceLengthType := Ord(tltUser); end; end; function GetDefaultProjectSettings: TProjectSettingRecord; var ProjectCurrency: TCurrency; {03.08.2007 FileStream: TFileStream; StreamSize: Integer; } begin ProjectCurrency := F_NormBase.DM.GetCountryCurrency; if ProjectCurrency.ID = 0 then ProjectCurrency := F_NormBase.DM.GetCurrencyByType(ctMain); ZeroMemory(@Result, SizeOf(TProjectSettingRecord)); Result.IDCurrency := ProjectCurrency.ID; Result.CurrencyRatio := ProjectCurrency.Ratio; Result.DefListName := cBaseCommon35; Result.DefRoomName := cBaseCommon36; Result.NDS := 20; Result.IsAutoSaveProject := true; Result.AutoSaveProjectMinutes := 25; //31.01.2012 10; Result.AutoSaveDateTimeMinutes := 10; Result.CustomerName := ''; Result.ContractorName := ''; Result.ListsInReverseOrder := true; Result.HeightThroughFloor := 0.7; Result.Unsigned := false; Result.OrganizationName := ''; if Not GUseArhOnlyMode then Result.PointComplIndexingMode := pcimInProject else Result.PointComplIndexingMode := pcimInTopCompon; Result.ReindexOrderType := rotCreated; Result.GUIDNBDir := ''; Result.TraceConnectOrder := ctPMOrder; {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} Result.TraceOnePortToOne := false; {$ELSE} Result.TraceOnePortToOne := true; {$IFEND} Result.TraceNoAskParams := false; Result.UseNormsFromInterfaces := true; Result.PointComonIndexingMode := cimInProject; Result.MarkMode := mmTemplate; Result.RoomNameShortSrcType := rnssRoomDefStr; Result.RoomNameShortDefault := 'XX'; Result.RoomNameShortIfNoRoom := 'XX'; Result.IsMarkByTemplateIfNoAtOtherMode := false; Result.UnitOfMeasure := GNBSettings.UOM; Result.Revision := 1; Result.DesignerInfo := ''; FillChar(Result.JobInfo, 1000, #0); FillChar(Result.CustomerInfo, 1000, #0); FillChar(Result.ContractorInfo, 1000, #0); Result.TagAdd := ''; Result.FirstTraceCreated := True; // Tolik -- 18/08/2021 -- первое создание трассы на проекте (по просьбе РОМЫ) {Result.LastGen_KatalogID := 0; Result.LastGen_KatalogSCSID := 0; Result.LastGen_CatalogRelationID := 0; Result.LastGen_ComponentID := 0; Result.LastGen_ComponentWholeID := 0; Result.LastGen_CatalogPropRelationID := 0; Result.LastGen_ComponentRelationID := 0; Result.LastGen_CompPropRelationID := 0; Result.LastGen_CableCanalConnectorsID := 0; Result.LastGen_ConnectedComponentsID := 0; Result.LastGen_InterfaceRelationID := 0; Result.LastGen_InterfOfInterfRelationID := 0; Result.LastGen_PortInterfaceRelationID := 0; Result.LastGen_NormsID := 0; Result.LastGen_NormResourceRelID := 0; Result.LastGen_ResourcesID := 0;} {03.08.2007 if FileExists(GetPathToDefProjSettings) then begin FileStream := TFileStream.Create(GetPathToDefProjSettings, fmOpenRead); try StreamSize := FileStream.Size; FileStream.Position := 0; if StreamSize <= SizeOf(TProjectSettingRecord) then FileStream.ReadBuffer(Result, StreamSize); finally FileStream.Free; end; end; } end; function GetDefaultRoomSettings: TRoomSettingRecord; begin ZeroMemory(@Result, SizeOf(TRoomSettingRecord)); end; function GetListParams(AIDList: Integer): TListParams; var //ListSetting: TListSettings; SCSList: TSCSList; begin try //Tolik //ZeroMemory(@Result, SizeOf(TListParams)); // на всякий // SCSList := nil; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList = nil then begin ZeroMemory(@Result, SizeOf(TListParams)); // на всякий {SCSList := TSCSList.Create(F_ProjMan); SCSList.Open(AIDList); //SCSList.CurrID := AIDList; Result := SCSList.GetParams; //Result.Name := SCSList.Name; //Result.MarkID := SCSList.MarkID; //Result.Settings := SCSList.Setting; SCSList.Free;} end else begin Result := SCSList.GetParams; //Result.Name := SCSList.Name; //Result.Settings := SCSList.Setting; //Result.MarkID := SCSList.MarkID; end; except on E: Exception do AddExceptionToLog('GetListParams: '+E.Message); end; end; function GetListParamsForNewList: TListParams; var idx: integer; begin ZeroMemory(@Result, SizeOf(TListParams)); Result.MarkID := -1; Result.IsIndexWithName := biTrue; //Result.MarkID := 1; //Result.Name := ''; //Result.Caption := ''; //Result.ID := 0; with F_ProjMan do begin if GSCSBase.CurrProject.Active then begin Result.MarkID := GSCSBase.CurrProject.GetMaxMarkIDFromChildReferences(itList) + 1; Result.Name := GSCSBase.CurrProject.Setting.DefListName; Result.Caption := Result.Name + ' ' + IntToStr(Result.MarkID); Result.Settings := GSCSBase.CurrProject.DefListSettings; //GSCSBase.CurrProject.Setting.ListSettingRecord; //03.08.2007 LoadDefListSettingsFromFile(Result.Settings); end else Result.Settings := GetDefaultListSettings(true); //Tolik 18/08/2021-- {$if defined(SCS_PE) } if Result.Settings.CadFontName = 'GOST' then Result.Settings.CadFontName := 'Tahoma'; {$IfEnd} if trim(Result.Settings.CadFontName) = '' then begin Result.Settings.CadFontName := 'Tahoma'; end; if Assigned(F_MasterNewList) then begin idx := F_MasterNewList.cbFontName.IndexOf(string(Result.Settings.CadFontName)); if idx = -1 then Result.Settings.CadFontName := 'Arial'; end; if GetOneStringSize(8, [], Result.Settings.CadFontName, true) = 0 then begin Result.Settings.CadFontName := 'Tahoma'; if Assigned(F_MasterNewList) then begin idx := F_MasterNewList.cbFontName.IndexOf(string(Result.Settings.CadFontName)); if idx = -1 then Result.Settings.CadFontName := 'Arial'; end; end; end; end; {function GetListSettingsByICatalog(AIDCatalog: Integer): TListSettingRecord; var IDList: Integer; begin IDList := F_ProjMan.DM.GetIDListByIDCatalog(AIDCatalog); Result := GetListParams(IDList).Settings; end;} function GetListDesignedName(ADesignFigureID: Integer): String; var FirstComponent: TSCSComponent; SCSObject: TSCSCatalog; SCSList: TSCSlist; begin Result := ''; FirstComponent := nil; SCSObject := nil; SCSList := nil; with F_ProjMan do begin if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(ADesignFigureID); if Assigned(SCSObject) then begin FirstComponent := SCSObject.GetFirstComponent; SCSList := SCSObject.GetListOwner; if Assigned(FirstComponent) and Assigned(SCSList) then begin //Result := FirstComponent.Name + ' '+FirstComponent.NameMark; //Result := Result +' ('+SCSList.GetNameForVisible(false)+')'; Result := cBaseCommon45+' - '+FirstComponent.GetNameForVisible(false); end; end; end; end; end; procedure LoadDefListSettingsFromFile(var AListSettings: TListSettingRecord); var FileStream: TFileStream; StreamSize: Integer; begin if FileExists(GetPathToDefListSettings) then begin FileStream := TFileStream.Create(GetPathToDefListSettings, fmOpenRead); try StreamSize := FileStream.Size; FileStream.Position := 0; if StreamSize <= SizeOf(TListSettingRecord) then FileStream.ReadBuffer(AListSettings, StreamSize); finally FileStream.Free; end; end; end; procedure LoadDefProjectSettingsFromFile(var AProjectSettings: TProjectSettingRecord); var FileStream: TFileStream; StreamSize: Integer; begin if FileExists(GetPathToDefProjSettings) then begin FileStream := TFileStream.Create(GetPathToDefProjSettings, fmOpenRead); try StreamSize := FileStream.Size; FileStream.Position := 0; if StreamSize <= SizeOf(TProjectSettingRecord) then FileStream.ReadBuffer(AProjectSettings, StreamSize); finally FileStream.Free; end; end; end; procedure DropCreatedObjCountOnClickInList(AListID: Integer); var SCSList: TSCSList; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then SCSList.FCreatedObjCountOnClick := 0; end; function GetCurrProjectParams(AWithProjRights: Boolean=true): TProjectParams; var ProjRights: Integer; begin Result.ID := -1; Result.MarkID := 0; Result.Caption := ''; Result.Name := ''; with F_ProjMan do if GSCSBase.CurrProject.Active then begin Result := GSCSBase.CurrProject.GetParams; if AWithProjRights then begin ProjRights := -1; if FProjUserInfo.ID <> 0 then ProjRights := FProjUserInfo.RightsPM else ProjRights := FCurrUserInfo.RightsPM; if GReadOnlyMode then ProjRights := rwrRead; if ProjRights = rwrRead then Result.Caption := Result.Caption +' ('+cBaseCommon46+')'; end; end; end; function GetProjectParamsForNew(ALoadUserParams: Boolean): TProjectParams; var MainCurrency: TCurrency; begin MainCurrency := F_NormBase.DM.GetCurrencyByType(ctMain); Result.ID := -1; Result.MarkID := F_ProjMan.DM.GetCatalogMaxMarkID(itProject, -1, qmPhisical) + 1; Result.Name := cBaseCommon37; Result.IsIndexWithName := biTrue; Result.Caption := Result.Name; if Result.IsIndexWithName = biTrue then Result.Caption := Result.Caption + ' ' + IntToStr(Result.MarkID); Result.Setting := GetDefaultProjectSettings; Result.DefListSetting := GetDefaultListSettings(true); Result.ServCanRecalcPricesByNDSChange := true; if ALoadUserParams then begin //*** Пользовательские настройки проекта по умолчанию LoadDefProjectSettingsFromFile(Result.Setting); //*** Пользовательские настройки нового листа по умолчанию LoadDefListSettingsFromFile(Result.DefListSetting); Result.Setting.FirstTraceCreated := True; end; { Result.Setting.IDCurrency := MainCurrency.ID; Result.Setting.CurrencyRatio := MainCurrency.Ratio; Result.Setting.DefListName := 'Лист'; Result.Setting.DefRoomName := 'Кабинет'; Result.Setting.NDS := 20; Result.Setting.IsAutoSaveProject := true; Result.Setting.AutoSaveProjectMinutes := 10; Result.Setting.AutoSaveDateTimeMinutes := 10; Result.Setting.ListSettingRecord.CableCanalFullnessKoef := 80; Result.Setting.ListSettingRecord.LengthKoef := 10; Result.Setting.ListSettingRecord.PortReserv := 0.5; Result.Setting.ListSettingRecord.MultiportReserv := 1; Result.Setting.ListSettingRecord.TwistedPairMaxLength := 100; Result.Setting.ListSettingRecord.CADClickObjectType := ct_Single; Result.Setting.ListSettingRecord.CADBlockStep := 4; Result.Setting.ListSettingRecord.CADGridStep := 1; Result.Setting.ListSettingRecord.CADHeight := 210; Result.Setting.ListSettingRecord.CADWidth := 297; Result.Setting.ListSettingRecord.CADPageOrient := poLandscape; Result.Setting.ListSettingRecord.CADPageSizeIndex := 4; Result.Setting.ListSettingRecord.CADShowRaise := true; Result.Setting.ListSettingRecord.CADStampType := stt_extended; Result.Setting.ListSettingRecord.CADTraceColor := clBlack; Result.Setting.ListSettingRecord.CADTraceStyle := psSolid; Result.Setting.ListSettingRecord.CADTraceWidth := 1; Result.Setting.ListSettingRecord.HeightRoom := 2.35; Result.Setting.ListSettingRecord.HeightCeiling := 0.15; Result.Setting.ListSettingRecord.HeightSocket := 0.3; Result.Setting.ListSettingRecord.HeightCorob := 0.7; Result.Setting.ListSettingRecord.ControlComplectJoinByProducer := true; Result.Setting.ListSettingRecord.ControlJoinByNetType := true; Result.Setting.ListSettingRecord.GroupListObjectsByType := true; Result.Setting.ListSettingRecord.NoteCountPrefix := 'x'; Result.Setting.ListSettingRecord.PutCableInTrace := true; Result.Setting.ListSettingRecord.ShowConnObjectCaption := true; Result.Setting.ListSettingRecord.ShowConnObjectNote := false; Result.Setting.ListSettingRecord.ShowLineObjectCaption := true; Result.Setting.ListSettingRecord.ShowLineObjectLength := true; Result.Setting.ListSettingRecord.ShowLineObjectNote := true; Result.Setting.ListSettingRecord.ShowObjectTypeCAD := st_Full; Result.Setting.ListSettingRecord.ShowObjectTypePM := st_Short; Result.Setting.ListSettingRecord.ListType := lt_Normal; Result.Setting.ListSettingRecord.IDFigureForDesignList := -1; Result.Setting.ListSettingRecord.IDListForDesignList := -1; } end; function CheckProjectInUse(AIDProject: Integer; var AUserName: String; var AUserDateTime: TDateTime): Boolean; var SCSProject: TSCSProject; begin SCSProject := TSCSProject.Create(F_ProjMan); Result := SCSProject.CheckProjectInUse(AIDProject, AUserName, AUserDateTime); SCSProject.Free; end; procedure SaveCurrProjectParams(AProjectParams: TProjectParams); begin with F_ProjMan do if GSCSBase.CurrProject.Active then GSCSBase.CurrProject.LoadParams(AProjectParams); end; // ##### находит ID Листа (выше/ниже) ##### function GetListIDForCreatePassage(AID_CurList: Integer; AParam: Integer): Integer; var NearList: TSCSList; NearSortID: integer; CurrList: TSCSList; List: TSCSList; i: integer; ResListID: Integer; strWhere: String; //ParentObject: TSCSCatalog; ListsInPlacingOrder: TSCSCatalogs; IndexOfCurrList: Integer; IndexOfPassageList: integer; SCSObject: TSCSCatalog; begin Result := -1; try CurrList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AID_CurList); if CurrList <> nil then begin ListsInPlacingOrder := GetChildCatalogsInPlacingOrder(CurrList.ProjectOwner, [itList]); IndexOfCurrList := ListsInPlacingOrder.IndexOf(CurrList); if IndexOfCurrList <> -1 then begin IndexOfPassageList := IndexOfCurrList + AParam; while (IndexOfPassageList >= 0) and (IndexOfPassageList <= (ListsInPlacingOrder.Count - 1)) do begin SCSObject := ListsInPlacingOrder[IndexOfPassageList]; if SCSObject is TSCSList then begin Result := TSCSList(SCSObject).CurrID; Break; //// BREAK //// end; IndexOfPassageList := IndexOfPassageList + AParam; end; end; FreeAndNil(ListsInPlacingOrder); end; {CurrList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AID_CurList); if CurrList <> nil then begin ParentObject := nil; if CurrList.Parent <> nil then if CurrList.Parent is TSCSCatalog then ParentObject := TSCSCatalog(CurrList.Parent); if ParentObject <> nil then begin IndexOfCurrList := ParentObject.ChildCatalogs.IndexOf(CurrList); if IndexOfCurrList <> -1 then begin IndexOfPassageList := IndexOfCurrList + AParam; while (IndexOfPassageList >= 0) and (IndexOfPassageList <= (ParentObject.ChildCatalogs.Count - 1)) do begin SCSObject := ParentObject.ChildCatalogs[IndexOfPassageList]; if SCSObject is TSCSList then begin Result := TSCSList(SCSObject).CurrID; Break; //// BREAK //// end; IndexOfPassageList := IndexOfPassageList + AParam; end; end; end; end; } {ResListID := -1; NearSortID := -1; NearList := nil; CurrList := nil; with F_ProjMan do begin CurrList := GSCSBase.CurrProject.GetListBySCSID(AID_CurList); if CurrList <> nil then for i := 0 to GSCSBase.CurrProject.ProjectLists.Count - 1 do begin List := GSCSBase.CurrProject.ProjectLists[i]; if List.CurrID <> AID_CurList then begin case AParam of -1: //*** Лист ниже if List.SortID < CurrList.SortID then if (List.SortID > NearSortID) or (NearSortID = -1) then begin NearSortID := List.SortID; NearList := List; end; 1: //*** Лист ниже if List.SortID > CurrList.SortID then if (List.SortID < NearSortID) or (NearSortID = -1) then begin NearSortID := List.SortID; NearList := List; end; end; end; end; end; if NearList <> nil then Result := NearList.CurrID;} except on E: Exception do AddExceptionToLog('GetListIDForCreatePassage: '+E.Message); end; end; //##### Вернет список ID Листов в порядке от первого параметра ко второму ##### function GetSortedListIDsByBounds(AIDEndList, AIDCurrList: Integer): TIntList; var EndList: TSCSList; CurrList: TSCSList; ProjectOwner: TSCSProject; BoundList: TSCSList; CheckingList: TSCSList; IDCheckingList: Integer; i: Integer; IncType: Integer; begin Result := TIntList.Create; if AIDEndList = AIDCurrList then Result.Add(AIDEndList) else begin EndList := nil; CurrList := nil; EndList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDEndList); CurrList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDCurrList); if (EndList <> nil) and (CurrList <> nil) then begin IncType := 0; IDCheckingList := -1; BoundList := nil; CheckingList := nil; if EndList.SortID < CurrList.SortID then IncType := 1 else if EndList.SortID > CurrList.SortID then IncType := -1; IDCheckingList := EndList.CurrID; CheckingList := EndList; BoundList := CurrList; if IncType <> 0 then while IDCheckingList > 0 do begin Result.Add(IDCheckingList); if IDCheckingList = BoundList.CurrID then Break; ///// BREAK ///// //*** Найти соседний лист IDCheckingList := GetListIDForCreatePassage(IDCheckingList, IncType); end; end; end; end; function GetUpperList(AIDList1, AIDList2: Integer): Integer; var List1: TSCSList; List2: TSCSList; SCSProject: TSCSProject; ItemList: TSCSCatalog; ListsInPlacingOrder: TSCSCatalogs; i: Integer; begin Result := -1; try with F_ProjMan do begin List1 := GSCSBase.CurrProject.GetListBySCSID(AIDList1); List2 := GSCSBase.CurrProject.GetListBySCSID(AIDList2); if (List1 <> nil) and (List2 <> nil) then begin //if List1.SortID > List2.SortID then // Result := AIDList1 //else // Result := AIDList2; SCSProject := List1.ProjectOwner; if ScsProject <> nil then begin ListsInPlacingOrder := GetChildCatalogsInPlacingOrder(SCSProject, [itList]); // Просматриваем листы сверху вниз for i := ListsInPlacingOrder.Count - 1 downto 0 do begin ItemList := ListsInPlacingOrder[i]; if (ItemList = List1) then begin Result := AIDList1; Break; //// BREAK //// end else if (ItemList = List2) then begin Result := AIDList2; Break; //// BREAK //// end; end; FreeAndNil(ListsInPlacingOrder); end; end; end; except on E: Exception do AddExceptionToLog('GetUpperList: '+E.Message); end; end; //*** Вернет Список сгруппированых типов компонент проекта (только по верхним компоненам) function GetCurrProectPointComponTypes: TObjectList; begin Result := nil; if CheckIsOpenProject(True) then Result := F_ProjMan.GSCSBase.CurrProject.GetUsingComponentTypes else Result := TObjectList.Create(false); end; Function GetNetworkTypesForSCSObject(ASCSObject: TObject): TObjectNetworkTypes; var ObjectNetworkTypes: TObjectNetworkTypes; SCSComponent: TSCSComponent; i: Integer; begin Result := []; if ASCSObject = nil then Exit; ////// EXIT ////// try ObjectNetworkTypes := []; for i := 0 to TSCSCatalog(ASCSObject).ComponentReferences.Count - 1 do begin SCSComponent := TSCSCatalog(ASCSObject).ComponentReferences[i]; case SCSComponent.IDNetType of ntComputer: if Not(nt_Computer in ObjectNetworkTypes) then ObjectNetworkTypes := ObjectNetworkTypes + [nt_Computer]; ntTelephone: if Not(nt_Telephon in ObjectNetworkTypes) then ObjectNetworkTypes := ObjectNetworkTypes + [nt_Telephon]; ntElectric: if Not(nt_Electric in ObjectNetworkTypes) then ObjectNetworkTypes := ObjectNetworkTypes + [nt_Electric]; ntTelevision: if Not(nt_Television in ObjectNetworkTypes) then ObjectNetworkTypes := ObjectNetworkTypes + [nt_Television]; ntGas: if Not(nt_Gas in ObjectNetworkTypes) then ObjectNetworkTypes := ObjectNetworkTypes + [nt_Gas]; end; end; Result := ObjectNetworkTypes; except on E: Exception do AddExceptionToLog('GetNetworkTypesForSCSObject: '+E.Message); end; end; Function GetNetworkTypesForObject(AID_Object: Integer): TObjectNetworkTypes; var SCSObject: TSCSCatalog; begin Result := []; try //SCSObject := TSCSCatalog.Create(F_ProjMan); //try //SCSObject.LoadCatalogByIDFigure(AID_Object, false, false); //SCSObject.LoadAllComponentsByObjectID(SCSObject.ID, [fiAll]); SCSObject := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AID_Object); if Assigned(SCSObject) then Result := GetNetworkTypesForSCSObject(SCSObject); //finally //SCSObject.Free; //end; except on E: Exception do AddExceptionToLog('GetNetworkTypesForObject: '+E.Message); end; end; //Tolik 16/10/2020 -- Переписана с учетом превышения величины поставки // (когда длина кабеля получается более, чем, например, в катушке) procedure DefineTracesWithExceedTwistedPair(AListID: Integer); var SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; SCSList: TSCSList; i, j: integer; HaveExceedCable: Boolean; Interfac: TSCSInterface; TwistedPairMaxLength: Double; StrTwistedPairMaxLength: string; ComponLength: Double; SprSuppliesKind: TNBSuppliesKind; // поставка ProjectOwner: TSCSProject; //проект SupplyLength: double;// длина кабеля в поставке begin SCSList := nil; SCSCatalog := nil; SCSComponent := nil; with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin SCSList := GSCSBase.CurrProject.GetListBySCSID(AListID); if Assigned(SCSList) then for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do begin SCSCatalog := SCSList.ChildCatalogReferences[i]; if SCSCatalog.ItemType = itSCSLine then begin HaveExceedCable := false; ProjectOwner := SCSCatalog.GetProject; // текуший проект for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin SCSComponent := SCSCatalog.ComponentReferences[j]; if isCableComponent(SCSComponent) then // если кабель -- begin SupplyLength := 0; if SCSComponent.GUIDSuppliesKind <> '' then // если определен тип поставки begin if ProjectOwner <> nil then begin SprSuppliesKind := ProjectOwner.Spravochnik.GetSuppliesKindByGUID(SCSComponent.GUIDSuppliesKind); if SprSuppliesKind <> nil then // если получили величину поставки ... begin SupplyLength := SprSuppliesKind.Data.UnitKolvo; //SupplyLength := FloatInUOM(SprSuppliesKind.Data.UnitKolvo, umMetr, ProjectOwner.Setting.UnitOfMeasure); {if CheckIsTradUOM(ProjectOwner.Setting.UnitOfMeasure) then begin end else begin end;} end; end; end; ComponLength := SCSComponent.GetPropertyValueAsFloat(pnLength); if SCSComponent.HaveInterfaceByGUIDInterface(guidTwistedPair) then begin //ComponLength := 0; //ComponLength := SCSComponent.GetPropertyValueAsFloat(pnLength); TwistedPairMaxLength := -1; StrTwistedPairMaxLength := SCSComponent.GetPropertyValueBySysName(pnTwistedPairMaxLength); if StrTwistedPairMaxLength <> '' then try TwistedPairMaxLength := StrToFloatU(CorrectStrToFloat(StrTwistedPairMaxLength)); except end; if TwistedPairMaxLength < 0 then TwistedPairMaxLength := SCSList.Setting.TwistedPairMaxLength; //if ComponLength > TwistedPairMaxLength then if (ComponLength > TwistedPairMaxLength) or ((SupplyLength > 0) and (ComponLength > SupplyLength)) then begin HaveExceedCable := true; Break; ///// BREAK ///// end; end; end; end; SetTraceLimitStatus(AListID, SCSCatalog.SCSID, HaveExceedCable); end; end; end; end; { procedure DefineTracesWithExceedTwistedPair(AListID: Integer); var SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; SCSList: TSCSList; i, j: integer; HaveExceedCable: Boolean; Interfac: TSCSInterface; TwistedPairMaxLength: Double; StrTwistedPairMaxLength: string; ComponLength: Double; begin SCSList := nil; SCSCatalog := nil; SCSComponent := nil; with F_ProjMan do if Assigned(GSCSBase.CurrProject) then if GSCSBase.CurrProject.Active then begin SCSList := GSCSBase.CurrProject.GetListBySCSID(AListID); if Assigned(SCSList) then for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do begin SCSCatalog := SCSList.ChildCatalogReferences[i]; if SCSCatalog.ItemType = itSCSLine then begin HaveExceedCable := false; for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin SCSComponent := SCSCatalog.ComponentReferences[j]; if SCSComponent.HaveInterfaceByGUIDInterface(guidTwistedPair) then begin ComponLength := 0; ComponLength := SCSComponent.GetPropertyValueAsFloat(pnLength); TwistedPairMaxLength := -1; StrTwistedPairMaxLength := SCSComponent.GetPropertyValueBySysName(pnTwistedPairMaxLength); if StrTwistedPairMaxLength <> '' then try TwistedPairMaxLength := StrToFloatU(CorrectStrToFloat(StrTwistedPairMaxLength)); except end; if TwistedPairMaxLength < 0 then TwistedPairMaxLength := SCSList.Setting.TwistedPairMaxLength; if ComponLength > TwistedPairMaxLength then begin HaveExceedCable := true; Break; ///// BREAK ///// end; end; end; SetTraceLimitStatus(AListID, SCSCatalog.SCSID, HaveExceedCable); end; end; end; end; } function GetObjIcon(AIDObjectIcon: Integer; AGUIDObjIcon: String; AIconType: Integer; ADBMode: TDBKind = bkProjectManager): TBitmap; var FNameBMP: String; Stream: TMemoryStream; begin Result := nil; try Stream := nil; case ADBMode of bkNormBase: Stream := F_NormBase.DM.GetComponIconByIconType(AIDObjectIcon, AIconType, ieBMP, AGUIDObjIcon); bkProjectManager: Stream := F_ProjMan.GSCSBase.CurrProject.Spravochnik.GetObjectIconByIconType(AGUIDObjIcon, AIconType, ieBMP); end; if Assigned(Stream) then try Stream.Position := 0; Result := TBitmap.Create; Result.LoadFromStream(Stream); finally FreeAndNil(Stream); end; except on E: Exception do AddExceptionToLog('GetObjIcon: '+E.Message); end; end; function GetObjIconForFigure(AIDList, AIDFigure, AIDObjectIcon: Integer; AGUIDObjIcon: String; AIconType: Integer): TBitmap; var SCSList: TSCSList; SCSCatalog: TSCSCatalog; begin Result := GetObjIcon(AIDObjectIcon, AGUIDObjIcon, AIconType); if Result = nil then begin SCSCatalog := nil; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); if SCSList <> nil then SCSCatalog := SCSList.GetCatalogFromReferencesBySCSID(AIDFigure); if SCSCatalog <> nil then if SCSCatalog.ProjectOwner <> nil then begin SCSCatalog.ProjectOwner.DefineSpravObjectIconFromCAD(AGUIDObjIcon, SCSCatalog); Result := GetObjIcon(AIDObjectIcon, AGUIDObjIcon, AIconType); end; end; end; procedure AddObjectIconFromCADToDirectories(AIconName, AFileIconBMP, AFileIconBlk: String); begin F_NormBase.F_CaseForm.AddObjectIconFromFile(AIconName, AFileIconBMP, AFileIconBlk); end; function ChangeObjIconInCAD(AIDFigure: Integer; AGUIDObjIcon: String; AIconType: Integer): TObjectIconParams; var NBIconForm: TF_CaseForm; NewIDIcon: Integer; NewGUIDIcon: string; IDObject: Integer; IDFirstCompon: Integer; SCSObject: TSCSCatalog; FirstCompon: TSCSComponent; SprObjectIcon: TNBObjectIcon; IconType: Integer; begin Result.IDIcon := 0; Result.IconBLK := nil; Result.IconBMP := nil; Result.Executed := false; ZeroMemory(@Result, SizeOf(TObjectIconParams)); IconType := AIconType; if IconType = oitNone then IconType := oitDefault; SCSObject := nil; FirstCompon := nil; try if ShowCurrProjectProperties(vkObjectIcons, AGUIDObjIcon) then if F_ProjMan.GSCSBase.CurrProject.Spravochnik.LastObjectIcon <> nil then begin SprObjectIcon := F_ProjMan.GSCSBase.CurrProject.Spravochnik.LastObjectIcon; NewIDIcon := SprObjectIcon.ID; NewGUIDIcon := SprObjectIcon.GUID; if NewGUIDIcon <> '' then begin //*** Занести обозначение в компонент with F_ProjMan do begin //IDObject := GetIDCatalogByIDFigure(AIDFigure); SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then FirstCompon := SCSObject.GetFirstComponent; if Assigned(FirstCompon) then begin FirstCompon.IDObjectIcon := NewIDIcon; FirstCompon.GUIDObjectIcon := NewGUIDIcon; FirstCompon.SaveComponent; end; RefreshTreeNodeComponent(Tree_Catalog.Selected); RefreshNode(true); end; Result.IDIcon := NewIDIcon; Result.GUIDIcon := NewGUIDIcon; //Result.IconBLK := F_NormBase.DM.GetComponIconByIconType(NewIDIcon, IconType, ieBLK); //Result.IconBMP := GetObjIcon(-1, NewGUIDIcon, IconType); Result.IconBLK := F_ProjMan.GSCSBase.CurrProject.Spravochnik.GetObjectIconByObject(SprObjectIcon, IconType, ieBLK); Result.IconBMP := GetObjIcon(-1, NewGUIDIcon, IconType, bkProjectManager); Result.Executed := true; end end; except on E: Exception do AddExceptionToLog('ChangeObjIconInCAD: '+E.Message); end { try NBIconForm := TF_CaseForm.Create(F_NormBase, TForm(F_NormBase), nil, itNone); try //if Not SearchRecord(F_NormBase.DM.DataSet_OBJECT_ICONS, fnID, AIDObjIcon) then // F_NormBase.DM.DataSet_OBJECT_ICONS.First; //DataSet_OBJECT_ICONS.Locate(fnID, AID_OBJECT_ICON, []); //DataSetLocateByID(F_NormBase.DM.DataSet_OBJECT_ICONS, AIDObjIcon); //NBIconForm.GIDNotDel := AIDObjIcon; //NBIconForm.GIDToLocate := AIDObjIcon; NBIconForm.GGUIDToLocate := AGUIDObjIcon; //NBIconForm.GViewKind := vkObjectIcons; //if NBIconForm.ShowModal = mrOK then if NBIconForm.Execute(vkObjectIcons, fmEdit) then begin NewIDIcon := F_NormBase.DM.DataSet_OBJECT_ICONS.FN(fnID).AsInteger; NewGUIDIcon := F_NormBase.DM.DataSet_OBJECT_ICONS.FN(fnGUID).AsString; if NewGUIDIcon <> '' then begin //*** Занести обозначение в компонент with F_ProjMan do begin //IDObject := GetIDCatalogByIDFigure(AIDFigure); SCSObject := GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then FirstCompon := SCSObject.GetFirstComponent; if Assigned(FirstCompon) then begin FirstCompon.IDObjectIcon := NewIDIcon; FirstCompon.GUIDObjectIcon := NewGUIDIcon; FirstCompon.SaveComponent; end; RefreshTreeNodeComponent(Tree_Catalog.Selected); RefreshNode(true); end; Result.IDIcon := NewIDIcon; Result.GUIDIcon := NewGUIDIcon; Result.IconBLK := F_NormBase.DM.GetComponIconByIconType(NewIDIcon, AIconType, ieBLK); Result.IconBMP := GetObjIcon(-1, NewGUIDIcon, AIconType); Result.Executed := true; end; end; finally FreeAndNil(NBIconForm); end; except on E: Exception do AddExceptionToLog('ChangeObjIconInCAD: '+E.Message); end; } end; function GetIconGUIDByIconID(AIconID: Integer): string; begin Result := ''; SetSQLToFIBQuery(F_NormBase.DM.Query_Select, GetSQLByParams(qtSelect, tnObjectIcons, fnID+' = :'+fnID, nil, fnGUID), false); F_NormBase.DM.Query_Select.ParamByName(fnID).AsInteger := AIconID; F_NormBase.DM.Query_Select.ExecQuery; if F_NormBase.DM.Query_Select.RecordCount > 0 then Result := F_NormBase.DM.Query_Select.FN(fnGUID).AsString; end; function GetFigureComponGraphicalImage(AIDFigure: Integer): TObjectList; var SCSObject: TSCSCatalog; ProjectOwner: TSCSProject; CupboardComponent: TSCSComponent; ChildComponent: TSCSComponent; i: Integer; function GetComponentDesignParams(AComponent: TSCSComponent; ATopComponent: Boolean): TComponentDesignParams; var Interfaces: TInterfLists; ptrInterfae: TSCSInterface; //InterfaceInfo: TInterfaceInfo; SprInterface: TNBInterface; ComponH: Double; fHeightInUnits: integer; Prop: PProperty; begin Result := nil; ptrInterfae := nil; if Assigned(AComponent) then begin ComponH := AComponent.GetPropertyValueAsFloat(pnHeight); if ComponH = 0 then begin Prop := AComponent.GetPropertyBySysName(pnHeightInUnits); if (AComponent.ComponentType.SysName = 'PATCH_PANEL') or (AComponent.ComponentType.SysName = 'ORGANIZER') or (Prop <> nil) then begin fHeightInUnits := AComponent.GetPropertyValueAsInteger(pnHeightInUnits); if fHeightInUnits = 0 then if ATopComponent then fHeightInUnits := 45 else fHeightInUnits := 2; ComponH := fHeightInUnits * cUnitHeight; end; end; if ComponH <> 0 then begin Result := TComponentDesignParams.Create; Result.Name := AComponent.Name; Result.NameShort := AComponent.NameShort; Result.NameMark := AComponent.NameMark; Result.Description := AComponent.GetNameForVisible(false); if AComponent.Notice <> '' then Result.Description := Result.Description + '-' + AComponent.Notice; Result.GraphicalImage := AComponent.GetGraphicalImageBlk; Result.Height := ComponH; Result.HeightInUnits := AComponent.GetPropertyValueAsInteger(pnHeightInUnits); //02.10.2012 - Если высота в Юнитах не задана, определяемм ее из обычной высоты if Result.HeightInUnits = 0 then Result.HeightInUnits := Round(ComponH / cUnitHeight); Result.UnitPos := AComponent.GetPropertyValueAsInteger(pnDesignUnitPos); Result.Width := AComponent.GetPropertyValueAsFloat(pnWidth); Result.BottomBound := AComponent.GetPropertyValueAsFloat(pnBottomBound); Result.LeftBound := AComponent.GetPropertyValueAsFloat(pnLeftBound); Result.RightBound := AComponent.GetPropertyValueAsFloat(pnRightBound); Result.TopBound := AComponent.GetPropertyValueAsFloat(pnTopBound); if Not ATopComponent then begin Interfaces := CupboardComponent.GetInterfacesThatConnectComponent(AComponent); if Assigned(Interfaces.InterfList1) and Assigned(Interfaces.InterfList2) then begin if Interfaces.InterfList2.Count > 0 then ptrInterfae := Interfaces.InterfList2[0]; SprInterface := nil; if ptrInterfae <> nil then SprInterface := ProjectOwner.Spravochnik.GetInterfaceByGUID(ptrInterfae.GUIDInterface); if SprInterface <> nil then Result.Width := SprInterface.ConstructiveWidth; //if ptrInterfae <> nil then // InterfaceInfo := F_NormBase.DM.GetInterfaceInfo(ptrInterfae.ID_Interface); //Result.Width := InterfaceInfo.ConstructiveWidth; // Tolik 14/05/2019 - - если будет Nil, то Free ебнется, а вот FreeAndNil проверяет на Nil //Interfaces.InterfList1.Free; //Interfaces.InterfList2.Free; FreeAndNil(Interfaces.InterfList1); FreeAndNil(Interfaces.InterfList2); // end; end; end; end; end; procedure ComponentDesignParamsToRes(AComponent: TSCSComponent; ATopComponent: Boolean); var Params: TComponentDesignParams; begin Params := GetComponentDesignParams(AComponent, ATopComponent); if Params <> nil then Result.Add(Params); end; procedure SortByUnitPos; var i,j: Integer; ItemI, ItemJ, ItemK: TComponentDesignParams; PrevPos, NewPrevPos: Integer; Exch: Boolean; EmptyDesignParams: TComponentDesignParams; StartIdx: Integer; begin StartIdx := 1; // Везде смотрим с 1-го, а не 0-го, чтобы шкаф остался в самом начале списка // Автозаполняем пропущенные позиции PrevPos := 0; for i := StartIdx to Result.Count - 1 do begin ItemI := TComponentDesignParams(Result[i]); if ItemI.UnitPos = 0 then begin NewPrevPos := 0; for j := i+1 to Result.Count - 1 do begin ItemJ := TComponentDesignParams(Result[j]); if ItemJ.UnitPos > 0 then // Если есть пространство между панелями if ((PrevPos + ItemI.HeightInUnits) < ItemJ.UnitPos) then NewPrevPos := PrevPos + 1 else begin NewPrevPos := 0; Break; //// BREAK //// end; end; if NewPrevPos <> 0 then begin ItemI.UnitPos := NewPrevPos; PrevPos := NewPrevPos; end; end else PrevPos := ItemI.UnitPos; end; // Sort for i := StartIdx to Result.Count - 1 do begin ItemI := TComponentDesignParams(Result[i]); for j := i+1 to Result.Count - 1 do begin ItemJ := TComponentDesignParams(Result[j]); // Если ItemI без позиции, или ItemI > ItemJ if ItemJ.UnitPos > 0 then if (ItemI.UnitPos = 0) or (ItemI.UnitPos > ItemJ.UnitPos) then begin ExchangeObjects(ItemI, ItemJ); Result[i] := ItemI; Result[j] := ItemJ; end; end; end; // Add empty objects between positions for i := StartIdx+1 to Result.Count - 1 do begin ItemI := TComponentDesignParams(Result[i-1]); ItemJ := TComponentDesignParams(Result[i]); if (ItemI.UnitPos+ItemI.HeightInUnits) < ItemJ.UnitPos then begin EmptyDesignParams := TComponentDesignParams.Create; EmptyDesignParams.HeightInUnits := ItemJ.UnitPos - (ItemI.UnitPos + ItemI.HeightInUnits); EmptyDesignParams.Height := EmptyDesignParams.HeightInUnits * cUnitHeight; EmptyDesignParams.UnitPos := ItemI.UnitPos + ItemI.HeightInUnits; EmptyDesignParams.Width := CupboardComponent.GetPropertyValueAsFloat(pnWidth); Result.Insert(i, EmptyDesignParams); end; end; end; begin Result := nil; SCSObject := nil; CupboardComponent := nil; SCSObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSObject) then begin ProjectOwner := SCSObject.ProjectOwner; CupboardComponent := SCSObject.ComponentReferences.GetComponentByType(ctsnCupboard); if Assigned(CupboardComponent) then if CupboardComponent.IsTemplate = biFalse then begin Result := TObjectList.Create(false); //Result.Add(GetComponentDesignParams(CupboardComponent, true)); ComponentDesignParamsToRes(CupboardComponent, true); for i := 0 to CupboardComponent.ChildComplects.Count - 1 do begin ChildComponent := CupboardComponent.ChildComplects[i]; if Assigned(ChildComponent) then //Result.Add(GetComponentDesignParams(ChildComponent, false)); ComponentDesignParamsToRes(ChildComponent, false); end; SortByUnitPos; Result.OwnsObjects := true; {Result.Add(CupboardComponent.GetGraphicalImageBlk); for i := 0 to CupboardComponent.ChildComplects.Count - 1 do begin ChildComponent := CupboardComponent.ChildComplects[i]; if Assigned(ChildComponent) then Result.Add(ChildComponent.GetGraphicalImageBlk); end; } end; end; end; { function GetConnectedTracesToConnetor(AIDList, AIDConnectorFigure: Integer): TIntList; var CADList: TF_CAD; ConnectorFigure: TConnectorObject; JoinedConnector: TConnectorObject; i, j, k: Integer; begin Result := TIntList.Create; ConnectorFigure := nil; CADList := GetListByID(AIDList); if CADList <> nil then ConnectorFigure := TConnectorObject(GetFigureByID(CADList, AIDConnectorFigure)); if ConnectorFigure <> nil then begin // трассы присоединены напрямую 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; end;} function GetLineComponsFromTracesJoinedToPoint(AIDList, AIDConnectorFigure: Integer): TObject; // TSCSComponents var LineFigureIDs: TIntList; i, j: Integer; SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; begin Result := TSCSComponents.Create(false); LineFigureIDs := GetConnectedTracesToConnetorByID(AIDList, AIDConnectorFigure); for i := 0 to LineFigureIDs.Count - 1 do begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(LineFigureIDs[i]); if SCSCatalog <> nil then for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do TSCSComponents(Result).Add(SCSCatalog.ComponentReferences[j]); end; LineFigureIDs.Free; end; function GetPointObjectConnectedTrunk(AListID, AFigureID: Integer): TCadCrossObject; var SCSObject: TSCSCatalog; SCSList: TSCSList; FirstComponent: TSCSComponent; CurrCadCrossObject: TCadCrossObject; begin Result := nil; SCSList := nil; SCSObject := nil; SCSList := F_projMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then SCSObject := F_projMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AFigureID); if SCSObject <> nil then begin FirstComponent := SCSObject.GetFirstComponent; if FirstComponent <> nil then begin Result := GetComponentTrunk(FirstComponent); ChangeCADCrossObject(SCSList, SCSObject.ID, Result); end; end; end; function GetOldPointObjectConnectedTrunk(AListID, AFigureID: Integer): TCadCrossObject; var SCSList: TSCSList; SCSObject: TSCSCatalog; begin Result := nil; SCSObject := nil; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then SCSObject := SCSList.GetCatalogFromReferencesBySCSID(AFigureID); if SCSObject <> nil then Result := SCSList.GetCADCrossObjectByObjectID(SCSObject.ID); end; function GetObjectIDsFromListBySameIcon(AListID, AFigureID: Integer; AGUIDObjectIcon: String): TIntList; var SCSList: TSCSList; SCSObjectParam: TSCSCatalog; SCSObject: TSCSCatalog; FirstComponentParam: TSCSComponent; FirstComponent: TSCSComponent; i: Integer; begin Result := TIntList.Create; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin SCSObjectParam := SCSList.GetCatalogFromReferencesBySCSID(AFigureID); FirstComponentParam := nil; if SCSObjectParam <> nil then FirstComponentParam := SCSObjectParam.GetFirstComponent; if FirstComponentParam <> nil then for i := 0 to SCSList.ChildCatalogReferences.Count - 1 do begin SCSObject := SCSList.ChildCatalogReferences[i]; if SCSObject <> SCSObjectParam then begin FirstComponent := SCSObject.GetFirstComponent; if FirstComponent <> nil then if (FirstComponent.GUIDObjectIcon = AGUIDObjectIcon) and (FirstComponent.ComponentType.SysName = FirstComponentParam.ComponentType.SysName) then Result.Add(SCSObject.SCSID); end; end; end; end; procedure LoadMaskTemplatesToForm(AForm: TForm; AItemID, AItemType: Integer; AIsMaking: Boolean); var List: TSCSList; MaskList: TList; begin if Assigned(AForm) then if AForm is TF_ComponTypesMarkMask then begin if AItemID = -1 then AIsMaking := true; List := nil; MaskList := nil; case AItemType of itList: if AIsMaking = false then begin List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AItemID); if List <> nil then MaskList := List.MarkMasks; end else MaskList := F_ProjMan.GSCSBase.CurrProject.MarkMasks; itProject: if AIsMaking = false then MaskList := F_ProjMan.GSCSBase.CurrProject.MarkMasks else MaskList := GetNBMarkTemplates; end; if Assigned(MaskList) then TF_ComponTypesMarkMask(AForm).LoadDataFromMarkMaskList(MaskList, AIsMaking); end; end; procedure SaveMaskTemplatesFromForm(AForm: TForm; AItemID, AItemType: Integer; AForAllObjects, AIsMaking: Boolean); {var List: TSCSList; ItemObject: TSCSCatalogExtended; SCSComponents: TSCSComponents; SCSComponent: TSCSComponent; SCSCatalogs: TSCSCatalogs; SCSCatalogsToDefineSignature: TSCSCatalogs; SCSCatalog: TSCSCatalog; MaskList: TList; i: Integer; //ptrOldCatalogMarkMask: PCatalogMarkMask; ptrCatalogMarkMask: PCatalogMarkMask; //OldMaskTemplates: TList; //TemplateNoChanged: Boolean; } begin {if Assigned(AForm) then if AForm is TF_ComponTypesMarkMask then begin ItemObject := nil; List := nil; MaskList := nil; SCSComponents := nil; SCSCatalogs := nil; case AItemType of itList: begin List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AItemID); if List <> nil then begin MaskList := List.MarkMasks; SCSComponents := List.ComponentReferences; SCSCatalogs := List.ChildCatalogReferences; end; ItemObject := List; end; itProject: begin MaskList := F_ProjMan.GSCSBase.CurrProject.MarkMasks; SCSComponents := F_ProjMan.GSCSBase.CurrProject.ComponentReferences; SCSCatalogs := F_ProjMan.GSCSBase.CurrProject.ChildCatalogReferences; ItemObject := F_ProjMan.GSCSBase.CurrProject; end; end; if Assigned(MaskList) then begin //OldMaskTemplates := TList.Create; //try // //*** Запомнить шаблоны маркировок перед изменением // for i := 0 to MaskList.Count - 1 do // begin // ptrCatalogMarkMask := MaskList[i]; // GetMem(ptrOldCatalogMarkMask, SizeOf(TCatalogMarkMask)); // ptrOldCatalogMarkMask^ := ptrCatalogMarkMask^; // OldMaskTemplates.Add(ptrOldCatalogMarkMask); // end; TF_ComponTypesMarkMask(AForm).SaveDataToMarkMaskList(MaskList); if AForAllObjects then begin SCSCatalogsToDefineSignature := TSCSCatalogs.Create(false); if Assigned(SCSComponents) then for i := 0 to SCSComponents.Count - 1 do begin SCSComponent := SCSComponents[i]; if Assigned(SCSComponent) then begin //ptrOldCatalogMarkMask := nil; ptrCatalogMarkMask := nil; if Assigned(ItemObject) then ptrCatalogMarkMask := ItemObject.GetMarkMaskByComponType(SCSComponent.ID_ComponentType); //ptrOldCatalogMarkMask := GetMarkMaskTemplateByCompTypeFromList(OldMaskTemplates, SCSComponent.ID_ComponentType); //TemplateNoChanged := false; //if (ptrOldCatalogMarkMask <> nil) and (ptrCatalogMarkMask <> nil) then // if ptrOldCatalogMarkMask.MarkMask = ptrCatalogMarkMask.MarkMask then // TemplateNoChanged := true; //if Not TemplateNoChanged then if (ptrCatalogMarkMask = nil) or (ptrCatalogMarkMask.MakeEdit in [meEdit, meMake]) then begin SCSCatalog := SCSComponent.GetFirstParentCatalog; SCSComponent.NameMark := F_ProjMan.MakeNameMarkComponent(SCSComponent, SCSCatalog, true); if Assigned(SCSComponent.TreeViewNode) then SCSComponent.TreeViewNode.Text := F_ProjMan.GetNameNode(SCSComponent.TreeViewNode, SCSComponent, true, true); if SCSCatalogsToDefineSignature.IndexOf(SCSCatalog) = -1 then SCSCatalogsToDefineSignature.Add(SCSCatalog); end; end; end; for i := 0 to SCSCatalogsToDefineSignature.Count - 1 do begin SCSCatalog := SCSCatalogsToDefineSignature[i]; if Assigned(SCSCatalog) then if SCSCatalog.ItemType in [itSCSConnector, itSCSLine] then F_ProjMan.F_ChoiceConnectSide.DefineObjectSignature(SCSCatalog); end; SCSCatalogsToDefineSignature.Free; end; //finally // FreeList(OldMaskTemplates); //end; end; end; } end; //procedure LoadMaskTemplatesFromFormToList(AList: TList); //begin // if Assigned(AList) then // F_MasterNewList.F_ComponTypesMarkMask.SaveDataToMarkMaskList(AList); //end; procedure CreateSpravochnikiInMasterNewList; begin F_MasterNewList.CreateSpravochniki; end; procedure LoadFromFormToItemSpravochnik(AForm: TForm; AItemID, AItemTypeOfSprav, AItemType: Integer; AForAllObjects, AForSelected, AReIndexCompons, AReindexComponsInChangedTypes, AReindexAllPointCompons, AIsMaking: Boolean; ASprElements: TSprElements; ADataPointer: Pointer); var List: TSCSList; ItemObject: TSCSCatalogExtended; SCSComponents: TSCSComponents; SCSComponent: TSCSComponent; SCSCatalogs: TSCSCatalogs; SCSCatalogsToDefineSignature: TSCSCatalogs; SCSCatalog: TSCSCatalog; i, j: Integer; Spravochnik: TSpravochnik; NBComponentType: TNBComponentType; RoomHeight: Double; CanRedefineMarkMask: Boolean; //LookedComponents: TSCSComponents; //WholeComponents: TSCSComponents; //PartComponent: TSCSComponent; GUIDComponTypeList: TStringList; ChangedCurrency: Boolean; SprSavedCurrencyM: TNBCurrency; SprSavedCurrencyS: TNBCurrency; SprCurrencyM: TNBCurrency; SprCurrencyS: TNBCurrency; ChangedInterfNorms: Boolean; CanRemarkMarkCompons: Boolean; //SavedReindexOrderType: TreindexOrderType; //SavedPointComonIndexingMode: TPointComonIndexingMode; //SavedPointComplIndexingMode: TPointComplIndexingMode; SavedProjSetting: TProjectSettingRecord; IsRestoreProjSettings: Boolean; begin if Assigned(AForm) then if AForm is TF_CaseForm then begin ItemObject := nil; List := nil; Spravochnik := nil; SCSComponents := nil; SCSCatalogs := nil; SCSCatalogsToDefineSignature := nil; CanRemarkMarkCompons := false; RoomHeight := TF_CaseForm(AForm).GetRoomHeight; case AItemTypeOfSprav of itList: begin List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AItemID); if List <> nil then begin Spravochnik := List.Spravochnik; SCSComponents := List.ComponentReferences; SCSCatalogs := List.ChildCatalogReferences; end; ItemObject := List; end; itProject: begin Spravochnik := F_ProjMan.GSCSBase.CurrProject.Spravochnik; SCSComponents := F_ProjMan.GSCSBase.CurrProject.ComponentReferences; SCSCatalogs := F_ProjMan.GSCSBase.CurrProject.ChildCatalogReferences; ItemObject := F_ProjMan.GSCSBase.CurrProject; if (TProjectParams(ADataPointer^).Setting.MarkMode <> F_ProjMan.GSCSBase.CurrProject.Setting.MarkMode) or TProjectParams(ADataPointer^).ServRemarkAllCompons then CanRemarkMarkCompons := true; // UNDO if AItemType = itProject then if AReIndexCompons or {AReindexComponsInChangedTypes or} AReindexAllPointCompons or TF_CaseForm(AForm).FChangedAnySpavElemen or CanRemarkMarkCompons then SaveCurrProjectToUndoStack; end; end; if Assigned(Spravochnik) then begin TF_CaseForm(AForm).SendFromMemTablesToSpravochnik(Spravochnik, ASprElements, @ChangedInterfNorms); //*** Обновить типы компонент с листа для самих компонент if AItemType = itList then for i := 0 to Spravochnik.ComponentTypes.Count - 1 do begin NBComponentType := TNBComponentType(Spravochnik.ComponentTypes[i]); if NBComponentType.IsModified then for j := 0 to SCSComponents.Count - 1 do begin SCSComponent := SCSComponents[j]; if SCSComponent.GUIDComponentType = NBComponentType.ComponentType.GUID then SCSComponent.ComponentType := NBComponentType.ComponentType; end; end; //*** Обрезать высоту размещения объектов там где она больше высоты комнаты if RoomHeight > 0 then for i := 0 to Spravochnik.ComponentTypes.Count - 1 do begin NBComponentType := TNBComponentType(Spravochnik.ComponentTypes[i]); if (NBComponentType.ComponentType.CoordZ <> -1) and (NBComponentType.ComponentType.CoordZ > RoomHeight) then NBComponentType.ComponentType.CoordZ := RoomHeight; end; //*** Отобрать объекты для применения параметров if AForAllObjects then begin SCSCatalogsToDefineSignature := TSCSCatalogs.Create(false); if Assigned(SCSComponents) then for i := 0 to SCSComponents.Count - 1 do begin SCSComponent := SCSComponents[i]; if Assigned(SCSComponent) then begin SCSCatalog := SCSComponent.GetFirstParentCatalog; if (AForSelected = false) or // Учитывать только выделенные объекты на КАДе CheckCADObjectSelect(SCSCatalog.ListID, SCSCatalog.SCSID) then begin NBComponentType := nil; if Assigned(ItemObject) then NBComponentType := Spravochnik.GetComponentTypeByGUID(SCSComponent.GUIDComponentType); //if Not TemplateNoChanged then if (NBComponentType = nil) or NBComponentType.IsModified then begin SCSComponent.NameMark := F_ProjMan.MakeNameMarkComponent(SCSComponent, SCSCatalog, true); if Assigned(SCSComponent.TreeViewNode) then SCSComponent.TreeViewNode.Text := F_ProjMan.GetNameNode(SCSComponent.TreeViewNode, SCSComponent, true, true); if SCSCatalogsToDefineSignature.IndexOf(SCSCatalog) = -1 then SCSCatalogsToDefineSignature.Add(SCSCatalog); end; end; end; end; end; //*** Учитывать переиндексацию if (AItemType = itProject) and (AReIndexCompons or AReindexAllPointCompons) then begin if SCSCatalogsToDefineSignature = nil then SCSCatalogsToDefineSignature := TSCSCatalogs.Create(false); //*** Определить типы компонентова, для переинтдексации GUIDComponTypeList := TStringList.Create; //*** Если переиндексация по типу компоненты if AReIndexCompons then for i := 0 to Spravochnik.ComponentTypes.Count - 1 do begin NBComponentType := TNBComponentType(Spravochnik.ComponentTypes[i]); if Not AReindexComponsInChangedTypes or NBComponentType.IsModified then GUIDComponTypeList.Add(NBComponentType.ComponentType.GUID); end; //*** Если переиндексация с 1-цы всех точ-х компонент if AReindexAllPointCompons then for i := 0 to Spravochnik.ComponentTypes.Count - 1 do begin NBComponentType := TNBComponentType(Spravochnik.ComponentTypes[i]); if NBComponentType.ComponentType.IsLine = biFalse then begin NBComponentType.ComponentType.ComponentIndex := 0; if GUIDComponTypeList.IndexOf(NBComponentType.ComponentType.GUID) = -1 then GUIDComponTypeList.Add(NBComponentType.ComponentType.GUID); end; end; if ItemObject is TSCSProject then begin // Установить новые параметры переиндексации SavedProjSetting := TSCSProject(ItemObject).Setting; IsRestoreProjSettings := true; try if ADataPointer <> nil then begin //TSCSProject(ItemObject).Setting.ReindexOrderType := TProjectParams(ADataPointer^).Setting.ReindexOrderType; //TSCSProject(ItemObject).Setting.PointComonIndexingMode := TProjectParams(ADataPointer^).Setting.PointComonIndexingMode; //TSCSProject(ItemObject).Setting.PointComplIndexingMode := TProjectParams(ADataPointer^).Setting.PointComplIndexingMode; TSCSProject(ItemObject).Setting := TProjectParams(ADataPointer^).Setting; end; // Переиндексация компонентов TSCSProject(ItemObject).ReindexComponentsByTypes(GUIDComponTypeList, SCSCatalogsToDefineSignature{, TSCSProject(ItemObject).Setting.ReindexOrderType}); finally TSCSProject(ItemObject).Setting := SavedProjSetting; end; end; FreeAndNil(GUIDComponTypeList); {LookedComponents := TSCSComponents.Create(False); for i := 0 to SCSComponents.Count - 1 do begin SCSComponent := SCSComponents[i]; NBComponentType := nil; if Assigned(ItemObject) then NBComponentType := Spravochnik.GetComponentTypeByGUID(SCSComponent.GUIDComponentType); if NBComponentType <> nil then if Not AReindexComponsInChangedTypes or NBComponentType.IsModified then begin SCSCatalog := SCSComponent.GetFirstParentCatalog; if LookedComponents.IndexOf(SCSComponent) = -1 then begin SCSComponent.MarkID := ItemObject.GenComponentMarkID(SCSComponent.GUIDComponentType); if SCSComponent.IsLine = biTrue then begin WholeComponents := ItemObject.GetComponentsByWholeID(SCSComponent.Whole_ID); for j := 0 to WholeComponents.Count - 1 do begin PartComponent := WholeComponents[j]; PartComponent.MarkID := SCSComponent.MarkID; LookedComponents.Add(PartComponent); end; FreeAndNil(WholeComponents); end; F_ProjMan.F_ChoiceConnectSide.DefineComponTrunkAfterChangeInFuture(SCSComponent, true); end; SCSComponent.NameMark := F_ProjMan.MakeNameMarkComponent(SCSComponent, SCSCatalog, true); if Assigned(SCSComponent.TreeViewNode) then SCSComponent.TreeViewNode.Text := F_ProjMan.GetNameNode(SCSComponent.TreeViewNode, SCSComponent, true, true); if SCSCatalogsToDefineSignature.IndexOf(SCSCatalog) = -1 then SCSCatalogsToDefineSignature.Add(SCSCatalog); end; end; FreeAndNil(LookedComponents);} end; // Перемаркировать компоненты IsRestoreProjSettings := false; try if (AItemType = itProject) and CanRemarkMarkCompons then begin if SCSCatalogsToDefineSignature = nil then SCSCatalogsToDefineSignature := TSCSCatalogs.Create(false); SavedProjSetting := TSCSProject(ItemObject).Setting; IsRestoreProjSettings := true; TSCSProject(ItemObject).Setting := TProjectParams(ADataPointer^).Setting; TSCSProject(ItemObject).RemarkComponents(SCSCatalogsToDefineSignature); end; //*** Переопределить параметры для выбранных объектов if SCSCatalogsToDefineSignature <> nil then begin F_ProjMan.F_ChoiceConnectSide.DefineObjectsParamsAfterChangeComponMark(SCSCatalogsToDefineSignature); //for i := 0 to SCSCatalogsToDefineSignature.Count - 1 do //begin // SCSCatalog := SCSCatalogsToDefineSignature[i]; // if Assigned(SCSCatalog) then // if SCSCatalog.ItemType in [itSCSConnector, itSCSLine] then // begin // OpenNoExistsListInCAD(SCSCatalog.GetListOwner); // F_ProjMan.F_ChoiceConnectSide.DefineObjectSignature(SCSCatalog); // end; //end; SCSCatalogsToDefineSignature.Free; end; finally if IsRestoreProjSettings then TSCSProject(ItemObject).Setting := SavedProjSetting; end; //*** Учитывать измененные валюты if vkCurrency in ASprElements then begin ChangedCurrency := false; SprSavedCurrencyM := Spravochnik.GetCurrencyBySavedType(ctMain); SprCurrencyM := Spravochnik.GetCurrencyByType(ctMain); if (SprSavedCurrencyM <> nil) and (SprCurrencyM <> nil) then if Not SprSavedCurrencyM.CheckEqualRatio(SprCurrencyM) then begin ChangedCurrency := true; ItemObject.RefreshPricesAfterChangeCurrency(SprSavedCurrencyM.Data, SprCurrencyM.Data, true); end; if Not ChangedCurrency then begin SprSavedCurrencyS := Spravochnik.GetCurrencyBySavedType(ctMain); SprCurrencyS := Spravochnik.GetCurrencyByType(ctMain); end; end; //*** Если на интерфейсе была изменена норма, то длины позже переопределить длины if ChangedInterfNorms then for i := 0 to SCSComponents.Count - 1 do begin SCSComponent := SCSComponents[i]; if SCSComponent.IsLine = biTrue then SCSComponent.RefreshWholeLengthInFuture; end; TF_Main(TF_CaseForm(AForm).GForm).RefreshNode(true); end; end; end; procedure LoadFromFormToSpravochnik(AItemType: Integer; ASpravochnik: TObject; ASprElements: TSprElements); var Spravochnik: TSpravochnik; Form: TForm; begin Spravochnik := TSpravochnik(ASpravochnik); if Spravochnik <> nil then begin Form := nil; case AItemType of itProject: begin Form := F_MasterNewList.F_ProjectSpravochnikForm; end; itList: begin Form := F_MasterNewList.F_ListSpravochnikForm; end; end; if (Form <> nil) and (Form is TF_CaseForm) then TF_CaseForm(Form).SendFromMemTablesToSpravochnik(Spravochnik, ASprElements, nil); end; end; procedure LoadFromItemSpravochnikToForm(AForm: TForm; AItemID, AItemType: Integer; AIsMaking: Boolean; ASprElements: TSprElements); var List: TSCSList; TmpProjObj: TSCSProject; Spravochnik: TSpravochnik; CreatedSpravochnik: Boolean; CurrViewKind: TViewKind; i: Integer; begin if Assigned(AForm) then if AForm is TF_CaseForm then begin if AItemID = -1 then AIsMaking := true; List := nil; Spravochnik := nil; CreatedSpravochnik := false; case AItemType of itList: if AIsMaking = false then begin List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AItemID); if List <> nil then begin //List.SynchonizeSpravochikElements(F_NormBase.GSCSBase.NBSpravochnik, [vkComponentType]); Spravochnik := List.Spravochnik; end; end else Spravochnik := F_ProjMan.GSCSBase.CurrProject.Spravochnik; itProject: if AIsMaking = false then begin //F_ProjMan.GSCSBase.CurrProject.SynchonizeSpravochikElements(F_NormBase.GSCSBase.NBSpravochnik, [vkInterface, vkComponentType, vkCurrency]); Spravochnik := F_ProjMan.GSCSBase.CurrProject.Spravochnik; end else begin TmpProjObj := TSCSProject.Create(TF_CaseForm(AForm).GForm); try Spravochnik := TSpravochnik.Create(TF_CaseForm(AForm).GForm, nil); //Spravochnik := F_NormBase.GSCSBase.NBSpravochnik; Spravochnik.OwnerObject := TmpProjObj; Spravochnik.AssignCurrencies(F_NormBase.GSCSBase.NBSpravochnik.Currencies); Spravochnik.AssignComponentTypes(F_NormBase.GSCSBase.NBSpravochnik.ComponentTypes, true); Spravochnik.DefineDataFromOtherSpravByNewGUIDs(F_NormBase.GSCSBase.NBSpravochnik); finally Spravochnik.OwnerObject := nil; TmpProjObj.Free; end; CreatedSpravochnik := true; end; end; if Assigned(Spravochnik) then begin TF_CaseForm(AForm).SendFromSpravochnikToMemTables(Spravochnik, ASprElements); CurrViewKind := vkNone; if TF_CaseForm(AForm).pcDirectories.ActivePage <> nil then CurrViewKind := TF_CaseForm(AForm).GetViewKindByTabSheet(TF_CaseForm(AForm).pcDirectories.ActivePage); if CurrViewKind <> vkNone then TF_CaseForm(AForm).PrepareForm(CurrViewKind, fmView); if CreatedSpravochnik then FreeAndNil(Spravochnik); end; end; end; function MakeEditProject(AMakeEdit: TMakeEdit; AIDProject: Integer; var AProjectParams: TProjectParams; ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; begin Result := false; if GLiteVersion and (AMakeEdit = meMake) and (not GReadOnlyMode) then Result := F_MasterNewListLite.MakeEditProject(AMakeEdit, AIDProject, AProjectParams, ASpravochnikKind, AGUIDToLocate) else Result := F_MasterNewList.MakeEditProject(AMakeEdit, AIDProject, AProjectParams, ASpravochnikKind, AGUIDToLocate); end; function GetNormsForCad(AListID: Integer): TList; (* var SCSList: TSCSList; NormResources: TSCSNormsResources; SCSNorm: TSCSNorm; NormPreyscurant: TSCSNormPreyscurant; i, j, k, l: Integer; RecNpp: Integer; ptrNormStructHeader: PNormStruct; ptrNormColumnHeader: PNormColumn; ptrNormCableColumn: PNormCableColumn; NormCableColumns: TList; ColumnIndex: Integer; ptrNormStruct: PNormStruct; ptrNormColumn: PNormColumn; ptrPrevNormColumn: PNormColumn; ptrResourceStruct: PNormStruct; ptrResourceColumn: PNormColumn; ptrResourceColumnIndex: PNormResourceColumnIndex; ResourceColumnIndexes: TList; ptrJoinedComponents: PJoinedComponents; LookedPointComponResourcesIDs: TIntList; LookedWholeIDs: TIntList; function FindNormCableColumnByPreyscurant(ANormPreyscurant: TSCSNormPreyscurant): PNormCableColumn; var i: Integer; ptrNormCableColumn: PNormCableColumn; begin Result := nil; for i := 0 to NormCableColumns.Count - 1 do begin ptrNormCableColumn := NormCableColumns[i]; if (ptrNormCableColumn.GUID = ANormPreyscurant.SCSComponentGUID) and (ptrNormCableColumn.PairKolvo = ANormPreyscurant.PairKolvo) then begin Result := ptrNormCableColumn; Break; //// BREAK //// end; end; end; function GetIndexNormCableColumnByPreyscurant(ANormPreyscurant: TSCSNormPreyscurant): Integer; var i: Integer; ptrNormCableColumn: PNormCableColumn; begin Result := -1; for i := 0 to NormCableColumns.Count - 1 do begin ptrNormCableColumn := NormCableColumns[i]; if (ptrNormCableColumn.GUID = ANormPreyscurant.SCSComponentGUID) and (ptrNormCableColumn.PairKolvo = ANormPreyscurant.PairKolvo) then begin Result := i; Break; //// BREAK //// end; end; end; procedure SortNormCableColumns; var i, j: Integer; ptrNormCableColumnI: PNormCableColumn; ptrNormCableColumnJ: PNormCableColumn; ptrTpmNormCableColumn: PNormCableColumn; begin for i := 0 to NormCableColumns.Count - 1 do begin ptrNormCableColumnI := NormCableColumns[i]; for j := i to NormCableColumns.Count - 1 do begin ptrNormCableColumnJ := NormCableColumns[j]; if ptrNormCableColumnJ.Name < ptrNormCableColumnI.Name then begin ptrTpmNormCableColumn := ptrNormCableColumnJ; ptrNormCableColumnJ := ptrNormCableColumnI; ptrNormCableColumnI := ptrNormCableColumnJ; end; end; end; end; function FindResourceColumnIndexInfo(AComponentNBGUID: String; AColumnIndex: Integer): PNormResourceColumnIndex; var ptrResourceColumnIndex: PNormResourceColumnIndex; i: Integer; begin Result := nil; for i := 0 to ResourceColumnIndexes.Count - 1 do begin ptrResourceColumnIndex := ResourceColumnIndexes[i]; if (TSCSComponent(ptrResourceColumnIndex.ResourceComponent).GuidNB = AComponentNBGUID){ and ((AColumnIndex = -1) or (ptrResourceColumnIndex.ColumnIndex = AColumnIndex))} then begin Result := ptrResourceColumnIndex; Break; //// BREAK //// end; end; end; function GetNewResourceColumnIndex(AColumnCount: Integer): PNormResourceColumnIndex; var i: Integer; begin GetZeroMem(Result, SizeOf(TNormResourceColumnIndex)); Result.Kolvos := TIntList.Create; Result.ComponIDs := TIntList.Create; for i := 0 to AColumnCount - 1 do Result.Kolvos.Add(0); end; function GetNewNormStruct(AColumnCount: Integer): PNormStruct; var ptrNormColumn: PNormColumn; i: Integer; begin GetZeroMem(Result, SizeOf(TNormStruct)); Result.FNormColumns := TList.Create; GetZeroMem(ptrNormColumn, SizeOf(TNormColumn)); Result.FNormColumns.Add(ptrNormColumn); ptrNormColumn.FColumns := TStringList.Create; //*** насыпать пустые значения в колонки for i := 0 to AColumnCount - 1 do ptrNormColumn.FColumns.Add(''); end; function AddConnComponToResorceColumn(AComponent: TSCSComponent; AColumnIndex: Integer): Boolean; var ptrResourceColumnIndex: PNormResourceColumnIndex; begin Result := false; ptrResourceColumnIndex := FindResourceColumnIndexInfo(AComponent.GuidNB, AColumnIndex); if ptrResourceColumnIndex = nil then begin ptrResourceColumnIndex := GetNewResourceColumnIndex(NormCableColumns.Count); ResourceColumnIndexes.Add(ptrResourceColumnIndex); ptrResourceColumnIndex.ResourceComponent := AComponent; ptrResourceColumnIndex.ColumnIndex := AColumnIndex; ptrResourceColumnIndex.Kolvo := 1; end; if ptrResourceColumnIndex <> nil then //if LookedPointComponResourcesIDs.IndexOf(AComponent.ID) = -1 then begin ptrResourceColumnIndex.Kolvos[ColumnIndex] := ptrResourceColumnIndex.Kolvos[ColumnIndex] + 1; LookedPointComponResourcesIDs.Add(AComponent.ID); Result := true; end; {if ptrResourceColumnIndex.ComponIDS.IndexOf(AComponent.ID) = -1 then begin ptrResourceColumnIndex.Kolvos[ColumnIndex] := ptrResourceColumnIndex.Kolvos[ColumnIndex] + 1; ptrResourceColumnIndex.ComponIDs.Add(AComponent.ID); Result := true; end;} end; procedure FreeNormResourceColumnIndexes(ANormResourceColumnIndexes: TList); var i: Integer; ptrResourceColumnIndex: PNormResourceColumnIndex; begin for i := 0 to ANormResourceColumnIndexes.Count - 1 do begin ptrResourceColumnIndex := ANormResourceColumnIndexes[i]; FreeAndNil(ptrResourceColumnIndex.Kolvos); FreeAndNil(ptrResourceColumnIndex.ComponIDs); end; FreeAndNil(ANormResourceColumnIndexes); end; *) begin Result := TList.Create; (* RecNpp := 0; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin NormResources := SCSList.GetAllNormsResources(nrAll, false, true, true, false); if NormResources.Norms.Count > 0 then begin GetZeroMem(ptrNormStructHeader, SizeOf(TNormStruct)); Result.Add(ptrNormStructHeader); ptrNormStructHeader.FNumber := cBaseCommon38_1; ptrNormStructHeader.FName := cBaseCommon38_2; ptrNormStructHeader.FIzm := cBaseCommon38_3; ptrNormStructHeader.FCount := cBaseCommon38_4; ptrNormStructHeader.FNormColumns := TList.Create; NormCableColumns := TList.Create; ResourceColumnIndexes := TList.Create; LookedPointComponResourcesIDs := TIntList.Create; LookedWholeIDs := TIntList.Create; //*** Проход #1 - построить шапку for i := 0 to NormResources.Norms.Count - 1 do begin SCSNorm := NormResources.Norms[i]; for j := 0 to SCSNorm.Preyscurants.Count - 1 do begin NormPreyscurant := TSCSNormPreyscurant(SCSNorm.Preyscurants[j]); if (NormPreyscurant.SCSComponent <> nil) and (NormPreyscurant.SCSComponent.IsLine = biTrue) then begin ptrNormCableColumn := FindNormCableColumnByPreyscurant(NormPreyscurant); if ptrNormCableColumn = nil then begin GetZeroMem(ptrNormCableColumn, SizeOf(TNormCableColumn)); NormCableColumns.Add(ptrNormCableColumn); ptrNormCableColumn.Name := NormPreyscurant.SCSComponent.NameShort; ptrNormCableColumn.GUID := NormPreyscurant.SCSComponentGUID; ptrNormCableColumn.PairKolvo := NormPreyscurant.PairKolvo; end; end; end; end; SortNormCableColumns; //*** Вкинуть Столбци в ptrNormStructHeader ptrPrevNormColumn := nil; for i := 0 to NormCableColumns.Count - 1 do begin ptrNormCableColumn := NormCableColumns[i]; ptrNormColumn := nil; if (ptrPrevNormColumn <> nil) and (ptrPrevNormColumn.FCableName = ptrNormCableColumn.Name) then ptrNormColumn := ptrPrevNormColumn else begin GetZeroMem(ptrNormColumn, SizeOf(TNormColumn)); ptrNormStructHeader.FNormColumns.Add(ptrNormColumn); ptrNormColumn.FColumns := TStringList.Create; end; ptrNormColumn.FCableName := ptrNormCableColumn.Name; ptrNormColumn.FColumns.Add(''); if ptrNormCableColumn.PairKolvo > 0 then ptrNormColumn.FColumns[ptrNormColumn.FColumns.Count - 1] := IntToStr(ptrNormCableColumn.PairKolvo); ptrPrevNormColumn := ptrNormColumn; end; //*** Проход #2 - Собрать инфу о подключенных точечных компонент-ресурсов for i := 0 to NormResources.Norms.Count - 1 do begin SCSNorm := NormResources.Norms[i]; for j := 0 to SCSNorm.Preyscurants.Count - 1 do begin NormPreyscurant := TSCSNormPreyscurant(SCSNorm.Preyscurants[j]); //*** Если норма применяется для прокладки линейн. компонент if NormPreyscurant.SCSComponent.IsLine = biTrue then begin ColumnIndex := GetIndexNormCableColumnByPreyscurant(NormPreyscurant); if (ColumnIndex <> -1) and (LookedWholeIDs.IndexOf(NormPreyscurant.SCSComponent.Whole_ID) = -1) then begin NormPreyscurant.SCSComponent.LoadNet; for k := 0 to NormPreyscurant.SCSComponent.Net.Count - 1 do begin ptrJoinedComponents := NormPreyscurant.SCSComponent.Net[k]; for l := 0 to ptrJoinedComponents.FirstConnCompons.Count - 1 do begin AddConnComponToResorceColumn(ptrJoinedComponents.FirstConnCompons[l], ColumnIndex); end; for l := 0 to ptrJoinedComponents.LastConnCompons.Count - 1 do begin AddConnComponToResorceColumn(ptrJoinedComponents.LastConnCompons[l], ColumnIndex); end; for l := 0 to ptrJoinedComponents.JoinedLines.Count - 1 do LookedWholeIDs.Add(ptrJoinedComponents.JoinedLines[l].Whole_ID); end; //for l := 0 to ptrJoinedComponents.JoinedLines.Count - 1 do // LookedWholeIDs.Add(ptrJoinedComponents.JoinedLines[l].Whole_ID); end; end; end; end; //*** Проход #3 - Закинуть в таблицу данные for i := 0 to NormResources.Norms.Count - 1 do begin SCSNorm := NormResources.Norms[i]; ptrNormStruct := GetNewNormStruct(NormCableColumns.Count); Result.Add(ptrNormStruct); Inc(RecNpp); ptrNormStruct.FNumber := IntToStr(RecNpp); ptrNormStruct.FName := SCSNorm.Name; ptrNormStruct.FIzm := SCSNorm.Izm; ptrNormColumn := ptrNormStruct.FNormColumns[0]; for j := 0 to SCSNorm.Preyscurants.Count - 1 do begin NormPreyscurant := TSCSNormPreyscurant(SCSNorm.Preyscurants[j]); ColumnIndex := -1; //*** Если норма применяется для прокладки линейн. компонент, то закинуть длины if NormPreyscurant.InterfaceType = itConstructive then begin if NormPreyscurant.SCSComponent.IsLine = biTrue then begin ColumnIndex := GetIndexNormCableColumnByPreyscurant(NormPreyscurant); if ColumnIndex <> -1 then ptrNormColumn.FColumns[ColumnIndex] := FloatToStr(RoundCP(NormPreyscurant.Kolvo)); end else begin //*** Закинуть ресурсы этой монтажной нормы ptrResourceStruct := GetNewNormStruct(NormCableColumns.Count); Result.Add(ptrResourceStruct); ptrResourceStruct.FName := NormPreyscurant.SCSComponent.NameShort; ptrResourceStruct.FIzm := NormPreyscurant.SCSComponent.Izm; ptrResourceStruct.FCount := FloatToStr(NormPreyscurant.Kolvo); ptrResourceColumn := ptrResourceStruct.FNormColumns[0]; ptrResourceColumnIndex := FindResourceColumnIndexInfo(NormPreyscurant.SCSComponent.GuidNB, ColumnIndex); if ptrResourceColumnIndex <> nil then begin //ptrResourceColumn.FColumns[ptrResourceColumnIndex.ColumnIndex] := IntToStr(ptrResourceColumnIndex.Kolvo); //for k := 0 to ptrResourceColumnIndex.Kolvos.Count - 1 do // if ptrResourceColumnIndex.Kolvos[k] > 0 then // ptrResourceColumn.FColumns[k] := IntToStr(ptrResourceColumnIndex.Kolvos[k]); //*** Убрать подключения с оборудования ResourceColumnIndexes.Remove(ptrResourceColumnIndex); FreeMem(ptrResourceColumnIndex); ptrResourceColumnIndex := nil; end else ptrResourceStruct.FCount := FloatToStr(NormPreyscurant.Kolvo); end; end; end; end; //*** Закинуть оставшиеся ресурсы по позициям for i := 0 to ResourceColumnIndexes.Count - 1 do begin ptrResourceColumnIndex := ResourceColumnIndexes[i]; ptrResourceStruct := GetNewNormStruct(NormCableColumns.Count); Result.Add(ptrResourceStruct); Inc(RecNpp); ptrResourceStruct.FNumber := IntToStr(RecNpp); ptrResourceStruct.FName := TSCSComponent(ptrResourceColumnIndex.ResourceComponent).NameShort; //NormPreyscurant.SCSComponent.NameShort; ptrResourceStruct.FIzm := TSCSComponent(ptrResourceColumnIndex.ResourceComponent).Izm; ptrResourceColumn := ptrResourceStruct.FNormColumns[0]; //ptrResourceColumn.FColumns[ptrResourceColumnIndex.ColumnIndex] := IntToStr(ptrResourceColumnIndex.Kolvo); for j := 0 to ptrResourceColumnIndex.Kolvos.Count - 1 do if ptrResourceColumnIndex.Kolvos[j] > 0 then ptrResourceColumn.FColumns[j] := IntToStr(ptrResourceColumnIndex.Kolvos[j]); end; //*** Очистить ненужное нах... FreeAndNil(LookedWholeIDs); FreeAndNil(lookedPointComponResourcesIDs); FreeNormResourceColumnIndexes(ResourceColumnIndexes); FreeList(NormCableColumns); FreeAndNil(NormResources); // FREE ResourceColumnIndexes // FREE NormCableColumns // FREE NormResources end; Exit; //*** Свормировать шапку if NormResources.Norms.Count > 0 then begin GetZeroMem(ptrNormStruct, SizeOf(TNormStruct)); Result.Add(ptrNormStruct); ptrNormStruct.FNumber := cBaseCommon38_1; ptrNormStruct.FName := cBaseCommon38_2; ptrNormStruct.FIzm := cBaseCommon38_3; ptrNormStruct.FCount := cBaseCommon38_4; ptrNormStruct.FNormColumns := TList.Create; ptrNormStruct.FNormColumns := TList.Create; for i := 0 to 2 do begin GetZeroMem(ptrNormColumn, SizeOf(TNormColumn)); ptrNormStruct.FNormColumns.Add(ptrNormColumn); ptrNormColumn.FCableName := cBaseCommon39+' ' + IntToStr(i+1); ptrNormColumn.FColumns := TStringList.Create; for j := 0 to i + 1 do ptrNormColumn.FColumns.Add(IntToStr((j+1) * 10)); end; end; for i := 0 to NormResources.Norms.Count - 1 do begin SCSNorm := NormResources.Norms[i]; GetZeroMem(ptrNormStruct, SizeOf(TNormStruct)); Result.Add(ptrNormStruct); ptrNormStruct.FNumber := IntToStr(i + 1); ptrNormStruct.FName := SCSNorm.Name; ptrNormStruct.FIzm := SCSNorm.Izm; ptrNormStruct.FCount := FloatToStr(RoundCP(SCSNorm.Kolvo)); ptrNormStruct.FNormColumns := TList.Create; GetZeroMem(ptrNormColumn, SizeOf(TNormColumn)); ptrNormStruct.FNormColumns.Add(ptrNormColumn); ptrNormColumn.FCableName := ''; ptrNormColumn.FColumns := TStringList.Create; for j := 0 to 8 do ptrNormColumn.FColumns.Add(IntToStr(i) + IntToStr(j)); //for j := 0 to 2 do //begin // GetZeroMem(ptrNormColumn, SizeOf(TNormColumn)); // ptrNormStruct.FNormColumns.Add(ptrNormColumn); // // ptrNormColumn.FCableName := ''; // ptrNormColumn.FColumns := TStringList.Create; // for k := 0 to j + 1 do // ptrNormColumn.FColumns.Add(IntToStr(i) + IntToStr(j) + IntToStr(k)); //end; end; end; *) end; function GetCurrentNormsForCAD(AListID: Integer): TObjectList; var SCSList: TSCSList; ShowNormContentsResources: Boolean; begin Result := TObjectList.Create(true); SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin ShowNormContentsResources := false; if GIsProgress then PauseProgress(true); try if MessageModal(cBaseCommon40, ApplicationName, MB_ICONQUESTION or MB_YESNO) = IDYES then ShowNormContentsResources := true; finally if GIsProgress then PauseProgress(false); end; SCSList.DefineCADNorms(false, ShowNormContentsResources); SCSList.CopyCADNormsToList(SCSList.CADNorms, Result); end; end; function GetOldNormsForCAD(AListID: Integer): TObjectList; var SCSList: TSCSList; begin Result := TObjectList.Create(true); SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then SCSList.CopyCADNormsToList(SCSList.CADNorms, Result); end; procedure SetNormsToListFromCAD(AListID: Integer; ANorms: TObjectList); var SCSList: TSCSList; Proj: TSCSProject; CADNormStruct: TCADNormStruct; CADNormColumn: TCADNormColumn; i, j: Integer; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin SCSList.AssignCADNorms(ANorms); Proj := TSCSProject(SCSList.GetTopParentCatalog); for i := 0 to SCSList.CADNorms.Count - 1 do begin CADNormStruct := TCADNormStruct(SCSList.CADNorms[i]); if CADNormStruct.ID = -1 then CADNormStruct.ID := Proj.GenIDByGeneratorIndex(giCADNormStructID); for j := 0 to CADNormStruct.NormColumns.Count - 1 do begin CADNormColumn := TCADNormColumn(CADNormStruct.NormColumns[j]); CADNormColumn.IDCADNormStruct := CADNormStruct.ID; if CADNormColumn.ID = -1 then CADNormColumn.ID := Proj.GenIDByGeneratorIndex(giCADNormColumnID); end; end; end; end; function UpdateNB(ADestBasePath: String = ''; AControlByBuildID: Boolean = false; AUpdaterPath: String = ''): Boolean; var odUpdateBase: TOpenDialog; CloseQueryEvent: TCloseQueryEvent; ProcAddr: procedure(Sender: TObject; var CanClose: Boolean); CanODExecute: Boolean; CanStartUpdate: Boolean; SrcBase: TBase; DestBasePath: String; OriginalPath: String; UpdaterPath: String; TmpUpdaterPath: String; UpdateBaseParams: TUpdateBaseParams; UpdateReults: TUpdateBaseResults; SavedIsComponent: Boolean; SavedObjectID: Integer; SelectedNode: TTreeNode; CanUpdate: Boolean; CurrConnectionCount: Integer; msgError: String; ErrCode: Integer; { procedure odUpdateBaseCanClose(Sender: TObject; var CanClose: Boolean); begin //ShowMessage('Beeeeeeeeeeeeeeeeeeeeeeeeep'); //CanClose := false; end;} procedure ShowOpenException(const AFileName, AMessage: String); begin MessageModal(cNoOpenUpdateSrcFileB+' "'+AFileName+'".'+#13+#10+#13+#10+ cErrorOpenFileDescription+AMessage, ApplicationName, MB_ICONERROR or MB_OK); end; begin Result := false; CanUpdate := true; DestBasePath := ADestBasePath; if DestBasePath = '' then DestBasePath := F_NormBase.GSCSBase.DBName; UpdaterPath := AUpdaterPath; OriginalPath := AUpdaterPath; TmpUpdaterPath := ''; if UpdaterPath = '' then if F_NormBase.CheckWriteNB(true) then begin odUpdateBase := TOpenDialog.Create(F_NormBase); try odUpdateBase.Options := odUpdateBase.Options - [ofOverWritePrompt]; {$if Defined(ES_GRAPH_SC)} odUpdateBase.InitialDir := ExeDir; {$else} odUpdateBase.InitialDir := ExtractFileDir(Application.ExeName); {$ifend} odUpdateBase.Filter := cFilesSrcUpdate+' (*.'+enUpd+')|*.'+enUpd+'| '+cAllFiles+' (*.*)|*.*'; odUpdateBase.DefaultExt := '*.'+enUpd; odUpdateBase.Title := cSelectFileWithSrcUpsate; {if AControlByBuildID then begin //ProcAddr := odUpdateBaseCanClose; @CloseQueryEvent := @odUpdateBaseCanClose; //ProcAddr; //MakeMethod(nil, @odUpdateBaseCanClose); odUpdateBase.OnCanClose := CloseQueryEvent; end;} CanODExecute := true; while CanODExecute do begin CanODExecute := false; TmpUpdaterPath := ''; if odUpdateBase.Execute then begin CanStartUpdate := true; UpdaterPath := odUpdateBase.FileName; OriginalPath := odUpdateBase.FileName; if AControlByBuildID then begin SrcBase := TBase.Create(F_NormBase.DM.ConnectParams); try {//17.03.2009 try UnPakFile(odUpdateBase.FileName); SrcBase.Open(odUpdateBase.FileName); except on E: EFIBInterBaseError do begin // Если ошибка при подключении, то копируем в темповую папку if E.IBErrorCode = 335544324 then begin TmpUpdaterPath := GetNoExistsFileNameForCopy(GetPathToSCSTmpDir +'\'+ TempDBName); if CopyBase(odUpdateBase.FileName, TmpUpdaterPath) then begin try SrcBase.Open(TmpUpdaterPath); UpdaterPath := TmpUpdaterPath; except on E: Exception do ShowOpenException(TmpUpdaterPath, E.Message); end; end else TmpUpdaterPath := ''; end else ShowOpenException(odUpdateBase.FileName, E.Message); end; on E: Exception do ShowOpenException(odUpdateBase.FileName, E.Message); end;} try TmpUpdaterPath := GetNoExistsFileNameForCopy(GetPathToSCSTmpDir +'\'+ TempDBName); if CopyBase(odUpdateBase.FileName, TmpUpdaterPath) then begin try if CheckPakedFile(TmpUpdaterPath) then UnPakFile(TmpUpdaterPath); SrcBase.Open(TmpUpdaterPath); UpdaterPath := TmpUpdaterPath; except on E: Exception do ShowOpenException(TmpUpdaterPath, E.Message); end; end else TmpUpdaterPath := ''; except on E: Exception do ShowOpenException(odUpdateBase.FileName, E.Message); end; if SrcBase.Active then begin if SrcBase.LoadSettings.BuildID < CurrentNBBuildID then if MessageModal(cFileOfSrcUpdate+' "'+odUpdateBase.FileName+'" '+cFileHaveOldStructure+'.'+#13+#10+ cQuastContinueUpdateFromThisFile, ApplicationName, MB_ICONQUESTION or MB_YESNO) <> IDYES then begin UpdaterPath := ''; CanStartUpdate := false; CanODExecute := true; if TmpUpdaterPath <> '' then DeleteFile(TmpUpdaterPath); end; end else begin UpdaterPath := ''; CanStartUpdate := false; CanODExecute := true; end; finally SrcBase.Free; end; end; end; end; finally odUpdateBase.Free; end; end; if UpdaterPath <> '' then begin //*** Проверка на количество подключений к базе CanUpdate := CheckConnectCountNoMoreOneToNB(cBaseCommon42); if CanUpdate then begin ZeroMemory(@UpdateBaseParams, SizeOf(TUpdateBaseParams)); SavedObjectID := 0; SavedIsComponent := false; if (F_NormBase <> nil) and (F_NormBase.Tree_Catalog.Selected <> nil) and (F_NormBase.Tree_Catalog.Selected.Data <> nil) then begin SavedObjectID := PObjectData(F_NormBase.Tree_Catalog.Selected.Data).ObjectID; case PObjectData(F_NormBase.Tree_Catalog.Selected.Data).ItemType of itDir: SavedIsComponent := false; itComponCon, itComponLine: SavedIsComponent := true; end; end; UpdateBaseParams.RequiredDBTypes := [dbtUsual, dbtUpdate, dbtCatalog, dbtComponent]; UpdateBaseParams.UpdateBaseMode := ubmUpdate; UpdateBaseParams.DestObjectGUID := guidCatalogUserDir; UpdateReults := UpdateNormBase(UpdaterPath, OriginalPath, DestBasePath, UpdateBaseParams, bbmUpdate, TmpUpdaterPath=''); if ubrSuccessful in UpdateReults then Result := true; UpdateNormBaseResultHandler(UpdateReults, UpdaterPath); //*** Обновить дерево и вернутся на прежнее место ClearTreeView(F_NormBase.Tree_Catalog); if Assigned(F_NormBase.GSCSBase) then begin if F_NormBase.GSCSBase.Active then begin F_NormBase.GSCSBase.Close; F_NormBase.GSCSBase.Open(F_NormBase.GSCSBase.DBName); end; //if Not F_NormBase.GSCSBase.Active then // F_NormBase.GSCSBase.SimpleOpen(true); //F_NormBase.AddNodes(nil); SelectedNode := nil; if SavedObjectID > 0 then SelectedNode := F_NormBase.FindComponOrDirInTree(SavedObjectID, SavedIsComponent); if SelectedNode <> nil then F_NormBase.Tree_Catalog.Selected := SelectedNode; end; end; end; if TmpUpdaterPath <> '' then DeleteFile(TmpUpdaterPath); end; function IsSpecialTraceFigure(AFigure: TOrthoLine): Boolean; var RaiseConn: TConnectorObject; begin Result := false; if aFigure <> nil then begin // Если простой сп if TOrtholine(aFigure).FIsRaiseUpDown then Result := true else begin RaiseConn := GetRaiseByRaiseLine(TOrtholine(aFigure)); 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 := True; end; end; end; function IsSpecialTrace(AListID, ATraceID, ATraceSCSID: Integer): Boolean; var SCSList: TSCSList; SCSCatalog: TSCSCatalog; TraceSCSID: Integer; TraceFigure: TFigure; RaiseConn: TConnectorObject; begin Result := false; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin TraceSCSID := ATraceSCSID; if TraceSCSID = 0 then begin SCSCatalog := SCSList.GetCatalogFromReferences(ATraceID); if SCSCatalog <> nil then TraceSCSID := SCSCatalog.SCSID; end; if TraceSCSID <> 0 then begin TraceFigure := GetFigureByListIDAndID(AListID, TraceSCSID); if TraceFigure <> nil then if TraceFigure is TOrtholine then begin // Если простой сп if TOrtholine(TraceFigure).FIsRaiseUpDown then Result := true else begin RaiseConn := GetRaiseByRaiseLine(TOrtholine(TraceFigure)); 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 := True; end; end; end; end; end; function GetAllTraceIDsInCADByEndLines(AFirstLineListID, ALastLineListID, AFirstLineFigureID, ALastLineFigureID: Integer): TIntList; var FirstLineFigure: TFigure; LastLineFigure: TFigure; AllTraceInCAD: TList; i: Integer; begin Result := TIntList.Create; try FirstLineFigure := GetFigureByListIDAndID(AFirstLineListID, AFirstLineFigureID); LastLineFigure := GetFigureByListIDAndID(ALastLineListID, ALastLineFigureID); if (FirstLineFigure <> nil) and (LastLineFigure <> nil) then begin AllTraceInCAD := GetAllTraceInCAD(FirstLineFigure, LastLineFigure); if AllTraceInCAD <> nil then begin for i := 0 to AllTraceInCAD.Count - 1 do Result.Add(TFigure(AllTraceInCAD[i]).ID); FreeAndNil(AllTraceInCAD); end; end; except on E: Exception do AddExceptionToLog('GetAllTraceIDsInCADByEndLines: '+E.Message); end; end; function GetFigureByListIDAndID(AListID, AFigureID: Integer): TFigure; var FList: TF_CAD; FFigure: TFigure; begin Result := nil; FList := GetListByID(AListID); if FList <> nil then Result := GetFigureByID(FList, AFigureID); end; (* function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; var List: TF_CAD; PointFigureRelations: TObjectList; PointFigures: TObjectList; CurrFigure: TFigure; CurrStepFigures: TRapList; FiguresInOrder: TRapList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TRapList; ListOfListConnectedObjects: TRapList; TotalTick: Cardinal; OldTick: Cardinal; GetCount: Integer; CountOfGetConnectedObjectsFromFinded: Integer; i: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TRapList); var ConnectedFigures: TRapList; begin ConnectedFigures := TRapList.Create; ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; { function GetConnectedObjectsFromFinded(AFigure: TFigure): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; i: Integer; begin Result := nil; //CountOfGetConnectedObjectsFromFinded := CountOfGetConnectedObjectsFromFinded + 1; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TRapList.Create; ConnectedFigures := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //Result.Assign(ConnectedFigures); for i := 0 to ConnectedFigures.Count - 1 do begin if FiguresInOrder.IndexOf(ConnectedFigures.List^[i]) = -1 then Result.Add(ConnectedFigures.List^[i]); end; end; end;} //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам if Result = nil then begin 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])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TRapList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TRapList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; if Result = nil then begin Result := TRapList.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]); if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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]); if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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 if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 if GetValueIndexFromSortedRapList(JoinedLine, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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 if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 if GetValueIndexFromSortedRapList(JoinedLine, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if GetValueIndexFromSortedRapList(FigureToResult, FiguresInOrder) = -1 then //if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end; end; { // Добавить в список подключаемых AddConnectedObjectsToFinded(AFigure, Result); // Выкинуть оюъекты, которые находятся в очереди i := Result.Count - 1; while i >= 0 do begin if FiguresInOrder.IndexOf(Result.List^[i]) <> -1 then Result.Delete(i); i := i-1; end;} end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TRapList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure AddRelation(AConnectorObject: TConnectorObject); var RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations.List^[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AConnectorObject.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали FirstTraceID := -1; LastTraceID := -1; if (PointFigureRelation.Traces.Count >= 2) and (CurrStepFigures.Count >= 2) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); if IsTrunkFigure(FirstConnector) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if IsTrunkFigure(TConnectorObject(AConnectorObject)) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AConnectorObject.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; end; procedure Step(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; FigureIndex: Integer; begin if (AFigure is TConnectorObject) and (AFigure <> FirstConnector) then begin AddRelation(TConnectorObject(AFigure)); end; //else begin //CurrStepFigures.Add(AFigure); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Эта проверка создавала небольшие тормоза, теперь это делается в GetConnectedObjects {i := 0; while i <= ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); if FiguresInOrder.IndexOf(ConnectedObject) <> -1 then ConnectedObjects.Delete(i) else Inc(i); end;} if ConnectedObjects.Count > 0 then begin CurrStepFigures.Add(AFigure); for i := 0 to ConnectedObjects.Count - 1 do InsertValueToSortetRapList(ConnectedObjects.List^[i], FiguresInOrder); //FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.AddList(ConnectedObjects); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); Step(TFigure(ConnectedObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.DeleteRange(FiguresInOrder.Count - ConnectedObjects.Count, ConnectedObjects.Count); for i := ConnectedObjects.Count - 1 downto 0 do begin FigureIndex := GetValueIndexFromSortedRapList(ConnectedObjects.List^[i], FiguresInOrder); if FigureIndex <> -1 then FiguresInOrder.Delete(FigureIndex); end; CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; ConnectedObjects.Free; //CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; begin Result := nil; PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFigures := TObjectList.Create(false); CurrStepFigures := TRapList.Create; FiguresInOrder := TRapList.Create; FiguresWithFindedConnections := TRapList.Create; ListOfListConnectedObjects := TRapList.Create; CountOfGetConnectedObjectsFromFinded := 0; for i := 0 to List.PCad.FigureCount - 1 do begin CurrFigure := TFigure(List.PCad.Figures[i]); if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; FiguresInOrder.Clear; FiguresInOrder.Add(FirstConnector); Step(FirstConnector, 0); end; ListOfListConnectedObjects.ClearOwnObjects; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); FreeAndNil(FiguresInOrder); FreeAndNil(PointFigures); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; end; *) function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; var List: TF_CAD; CurrList: TForm; PointFigureRelations: TObjectList; PointFigures: TObjectList; CurrFigure: TFigure; CurrStepFigures: TRapList; //FiguresInOrder: TRapList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TRapList; ListOfListConnectedObjects: TRapList; // Tolik 28/08/2019 -- //TotalTick: Cardinal; //OldTick: Cardinal; TotalTick, OldTick: DWord; // GetCount: Integer; CountOfGetConnectedObjectsFromFinded: Integer; i, j: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TRapList); var ConnectedFigures: TRapList; begin ConnectedFigures := TRapList.Create; ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; { function GetConnectedObjectsFromFinded(AFigure: TFigure): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; i: Integer; begin Result := nil; //CountOfGetConnectedObjectsFromFinded := CountOfGetConnectedObjectsFromFinded + 1; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TRapList.Create; ConnectedFigures := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //Result.Assign(ConnectedFigures); for i := 0 to ConnectedFigures.Count - 1 do begin if FiguresInOrder.IndexOf(ConnectedFigures.List^[i]) = -1 then Result.Add(ConnectedFigures.List^[i]); end; end; end;} //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам //if Result = nil then if IndexFigure = -1 then begin 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])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; end else begin FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(nil); end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TRapList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TRapList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; if Result = nil then begin Result := TRapList.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]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; 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]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; 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) or (ConnRaiseType = crt_TrunkUp) or (ConnRaiseType = crt_TrunkDown) 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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end; // Сторона 2 ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector2); ConnRaiseType := ConnObject.FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) or (ConnRaiseType = crt_TrunkUp) or (ConnRaiseType = crt_TrunkDown) 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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end; end; { // Добавить в список подключаемых AddConnectedObjectsToFinded(AFigure, Result); // Выкинуть оюъекты, которые находятся в очереди i := Result.Count - 1; while i >= 0 do begin if FiguresInOrder.IndexOf(Result.List^[i]) <> -1 then Result.Delete(i); i := i-1; end;} end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if AConnector.FTrunkName <> '' then if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TRapList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure AddRelation(AConnectorObject: TConnectorObject); var RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations.List^[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AConnectorObject.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали //FirstTraceID := -1; //LastTraceID := -1; if (PointFigureRelation.Traces.List.Count >= 2) and (CurrStepFigures.Count >= 2) then begin //FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); //LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); //if CheckedAsReverse then // ExchangeIntegers(FirstTraceID, LastTraceID); if (FirstConnector.FTrunkName <> '') and IsTrunkFigure(FirstConnector) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if (TConnectorObject(AConnectorObject).FTrunkName <> '') and IsTrunkFigure(TConnectorObject(AConnectorObject)) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; if FirstConnector.FHouse <> nil then PointFigureRelation.FirstPointFigure := FirstConnector.FHouse.ID; PointFigureRelation.LastPointFigure := AConnectorObject.ID; if AConnectorObject.FHouse <> nil then PointFigureRelation.LastPointFigure := AConnectorObject.FHouse.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; end; procedure IncFigureTags(AFigureList: TRapList); var i: Integer; begin for i := 0 to AFigureList.Count - 1 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then TConnectorObject(AFigureList.List^[i]).FTagPM := TConnectorObject(AFigureList.List^[i]).FTagPM + 1 else if TFigure(AFigureList.List^[i]) is TOrtholine then TOrtholine(AFigureList.List^[i]).FTagPM := TOrtholine(AFigureList.List^[i]).FTagPM + 1; end; end; procedure DecFigureTags(AFigureList: TRapList); var i: Integer; begin for i := AFigureList.Count - 1 downto 0 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then begin if TConnectorObject(AFigureList.List^[i]).FTagPM > 0 then TConnectorObject(AFigureList.List^[i]).FTagPM := TConnectorObject(AFigureList.List^[i]).FTagPM - 1; end else if TFigure(AFigureList.List^[i]) is TOrtholine then if TOrtholine(AFigureList.List^[i]).FTagPM > 0 then TOrtholine(AFigureList.List^[i]).FTagPM := TOrtholine(AFigureList.List^[i]).FTagPM - 1; end; end; procedure Step(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and (AFigure <> FirstConnector) then begin AddRelation(TConnectorObject(AFigure)); end; //else begin //CurrStepFigures.Add(AFigure); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Эта проверка создавала небольшие тормоза, теперь это делается в GetConnectedObjects {i := 0; while i <= ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); if FiguresInOrder.IndexOf(ConnectedObject) <> -1 then ConnectedObjects.Delete(i) else Inc(i); end;} if ConnectedObjects.Count > 0 then begin CurrStepFigures.Add(AFigure); //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.AddList(ConnectedObjects); // Запомнить очередь в тагах IncFigureTags(ConnectedObjects); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); Step(TFigure(ConnectedObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.DeleteRange(FiguresInOrder.Count - ConnectedObjects.Count, ConnectedObjects.Count); DecFigureTags(ConnectedObjects); CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; ConnectedObjects.Free; //CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; procedure DropAllFigureTags; var i, j: Integer; begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then //Tolik -- 28/06/2016 -- // for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do for j := 0 to TF_CAD(CurrList).FSCSFigures.Count - 1 do // begin // Tolik //CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); CurrFigure := TFigure(TF_CAD(CurrList).FSCSFigures[j]); // if CurrFigure is TConnectorObject then TConnectorObject(CurrFigure).FTagPM := 0 else if CurrFigure is TOrthoLine then TOrthoLine(CurrFigure).FTagPM := 0; end; end; end; begin Result := nil; PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFigures := TObjectList.Create(false); CurrStepFigures := TRapList.Create; //FiguresInOrder := TRapList.Create; FiguresWithFindedConnections := TRapList.Create; ListOfListConnectedObjects := TRapList.Create; CountOfGetConnectedObjectsFromFinded := 0; //// Сбросить таги //DropAllFigureTags; // Отобрать все точ-е объекты с текущего листа //Tolik 28/06/2016 -- //for i := 0 to List.PCad.FigureCount - 1 do for i := 0 to List.FSCSFigures.Count - 1 do // begin //Tolik 28/06/2016-- //CurrFigure := TFigure(List.PCad.Figures[i]); CurrFigure := TFigure(List.FSCSFigures[i]); // if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; //FiguresInOrder.Clear; //FiguresInOrder.Add(FirstConnector); // Сбросить таги DropAllFigureTags; FirstConnector.FTagPM := 1; Step(FirstConnector, 0); FirstConnector.FTagPM := 0; end; ListOfListConnectedObjects.ClearOwnObjects; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); //FreeAndNil(FiguresInOrder); FreeAndNil(PointFigures); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; end; function GetPointObjectRelationsBetweenListDistr(AIDList: Integer): TObjectList; var List: TF_CAD; CurrList: TForm; AllPointFigures: TList; ProjPointFigures: TList; ProjLineFigures: TList; PointFigureRelations: TObjectList; PointFiguresAll: TRapList; PointFigures: TObjectList; CurrPointFigures: TRapList; CurrFigure: TFigure; ConnectedToFigure: TFigure; CurrStepFigures: TRapList; //FiguresInOrder: TRapList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TRapList; ListOfListConnectedObjects: TRapList; //ConnectorsInComplexObj: TRapList; //ConnectorsFromTrunk: TRapList; //TrunksForConnectors: TRapList; CurrDistance: Double; //DeltaDistance: Double; //Tolik 28/08/2019 -- //TotalTick: Cardinal; //OldTick: Cardinal; TotalTick, OldTick: DWord; // GetCount: Integer; CountOfGetConnectedObjectsFromFinded: Integer; i, j: Integer; //Tolik 28/08/2019 -- //TickAddRelation: Cardinal; TickAddRelation: DWord; // procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TRapList); var ConnectedFigures: TRapList; begin ConnectedFigures := TRapList.Create; ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; { function GetConnectedObjectsFromFinded(AFigure: TFigure): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; i: Integer; begin Result := nil; //CountOfGetConnectedObjectsFromFinded := CountOfGetConnectedObjectsFromFinded + 1; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TRapList.Create; ConnectedFigures := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //Result.Assign(ConnectedFigures); for i := 0 to ConnectedFigures.Count - 1 do begin if FiguresInOrder.IndexOf(ConnectedFigures.List^[i]) = -1 then Result.Add(ConnectedFigures.List^[i]); end; end; end;} //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TConnectorObject; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TConnectorObject(ListOfListConnectedObjects.List^[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам //if Result = nil then if IndexFigure = -1 then begin 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])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; } FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnOfPassage); Result := ConnOfPassage; end else begin FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(nil); end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TRapList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TConnectorObject; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; try if Result = nil then begin Result := TRapList.Create; if AFigure is TConnectorObject then begin ConnRaiseType := TConnectorObject(AFigure).FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) or (ConnRaiseType = crt_TrunkUp) or (ConnRaiseType = crt_TrunkDown) then begin {ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(TConnectorObject(AFigure)); if ConnectedObjectsFromBetweenFloorConnector <> nil then for i := 0 to ConnectedObjectsFromBetweenFloorConnector.Count - 1 do begin FigureToResult := TFigure(ConnectedObjectsFromBetweenFloorConnector.List^[i]); if FigureToResult is TOrtholine then if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end;} ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(TConnectorObject(AFigure)); if ConnectedObjectsFromBetweenFloorConnector <> nil then Result.Add(ConnectedObjectsFromBetweenFloorConnector); for i := 0 to TConnectorObject(AFigure).JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(TConnectorObject(AFigure).JoinedOrtholinesList.List^[i])); end else //if TConnectorObject(AFigure).ConnectorType = ct_Clear then begin if TConnectorObject(AFigure).JoinedConnectorsList.Count > 0 then begin 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]); if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end; end; end; //else 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]); if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end; 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) or (ConnRaiseType = crt_TrunkUp) or (ConnRaiseType = crt_TrunkDown) then begin if PPointFigureSearchInfo(ConnObject.FTagPM).OrderCount = 0 then Result.Add(ConnObject); end else begin // Если к коннетору не подключены точ. объекты if ConnObject.JoinedConnectorsList.Count = 0 then begin if PPointFigureSearchInfo(ConnObject.FTagPM).OrderCount = 0 then Result.Add(ConnObject); end else if PPointFigureSearchInfo(TConnectorObject(ConnObject).FTagPM).ComplexObject <> nil then //if ConnectorsInComplexObj.IndexOf(ConnObject) <> -1 then Result.Add(ConnObject) else for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if PPointFigureSearchInfo(TConnectorObject(FigureToResult).FTagPM).OrderCount = 0 then Result.Add(FigureToResult); end; end; { 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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end;} // Сторона 2 ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector2); ConnRaiseType := ConnObject.FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) or (ConnRaiseType = crt_TrunkUp) or (ConnRaiseType = crt_TrunkDown) then begin Result.Add(ConnObject); end else begin // Если к коннетору не подключены точ. объекты if ConnObject.JoinedConnectorsList.Count = 0 then Result.Add(ConnObject) else begin if PPointFigureSearchInfo(TConnectorObject(ConnObject).FTagPM).ComplexObject <> nil then //if ConnectorsInComplexObj.IndexOf(ConnObject) <> -1 then Result.Add(ConnObject) else for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); Result.Add(FigureToResult); end; end; end; {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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end;} end; { // Добавить в список подключаемых AddConnectedObjectsToFinded(AFigure, Result); // Выкинуть оюъекты, которые находятся в очереди i := Result.Count - 1; while i >= 0 do begin if FiguresInOrder.IndexOf(Result.List^[i]) <> -1 then Result.Delete(i); i := i-1; end;} end; except on E: Exception do AddExceptionToLogEx('GetPointObjectRelationsBetweenListDistr:GetConnectedObjects', E.Message); end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if AConnector.FTrunkName <> '' then if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TRapList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; function GetConnectorObjectByType(AObject: TConnectorObject): TConnectorObject; //var // ObjectIndex: Integer; begin Result := nil; if AObject.ConnectorType <> ct_Clear then Result := AObject else begin //ObjectIndex := ConnectorsFromTrunk.IndexOf(AObject); //if ObjectIndex <> -1 then // Result := TConnectorObject(TrunksForConnectors[ObjectIndex]); if PPointFigureSearchInfo(AObject.FTagPM).ComplexObject <> nil then if PPointFigureSearchInfo(AObject.FTagPM).ComplexObject is TConnectorObject then Result := TConnectorObject(PPointFigureSearchInfo(AObject.FTagPM).ComplexObject) else if PPointFigureSearchInfo(AObject.FTagPM).ComplexObject is THouse then Result := AObject; end; end; procedure AddRelation(AConnectorObject: TConnectorObject; ARotatePath: Boolean); var ConnectorObject: TConnectorObject; FirstConnectorObject: TConnectorObject; RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; FigureWithSearchInfo: TConnectorObject; FigureToSearchInfo: TConnectorObject; FigSearchInfo: PPointFigureSearchInfo; PointFiguresRelIdx: Integer; // Tolik 28/08/2019 //OldTick: Cardinal; OldTick: DWord; // begin //OldTick := GetTickCount; ConnectorObject := GetConnectorObjectByType(AConnectorObject); FirstConnectorObject := GetConnectorObjectByType(FirstConnector); if (ConnectorObject <> nil) and (FirstConnectorObject <> nil) then begin //15.01.2013 - определяем в каком объекте хранится список найденных соединений, смотрим по меньшему id FigureWithSearchInfo := nil; FigureToSearchInfo := nil; if ConnectorObject.ID < FirstConnectorObject.ID then begin FigureWithSearchInfo := ConnectorObject; FigureToSearchInfo := FirstConnectorObject; end else begin FigureWithSearchInfo := FirstConnectorObject; FigureToSearchInfo := ConnectorObject; end; FigSearchInfo := Pointer(TConnectorObject(FigureWithSearchInfo).FTagPM); //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; if FigSearchInfo.FPointFiguresRels <> nil then //15.01.2013 begin PointFiguresRelIdx := GetValueIndexFromSortedRapList(Pointer(FigureToSearchInfo.ID), FigSearchInfo.FPointFiguresRelsID); if PointFiguresRelIdx <> -1 then for i := PointFiguresRelIdx to FigSearchInfo.FPointFiguresRelsID.Count - 1 do begin //15.01.2013 если дошли на другой объект, то прекращаем поиск if FigSearchInfo.FPointFiguresRelsID[i] <> Pointer(FigureToSearchInfo.ID) then Break; //// BREAK //// PointFigureRelation := TPointFigureRelation(FigSearchInfo.FPointFiguresRels.List^[i]); //15.01.2013 for i := 0 to PointFigureRelations.Count - 1 do //15.01.2013 begin //15.01.2013 PointFigureRelation := TPointFigureRelation(PointFigureRelations.List^[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnectorObject.ID) and (PointFigureRelation.LastPointFigure = ConnectorObject.ID)) then RelationExists := true else if ((PointFigureRelation.LastPointFigure = FirstConnectorObject.ID) and (PointFigureRelation.FirstPointFigure = ConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали //FirstTraceID := -1; //LastTraceID := -1; if (PointFigureRelation.Traces.List.Count >= 2) and (CurrStepFigures.Count >= 2) then begin //FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); //LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); //if CheckedAsReverse then // ExchangeIntegers(FirstTraceID, LastTraceID); if (FirstConnectorObject.FTrunkName <> '') and IsTrunkFigure(FirstConnectorObject) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if (TConnectorObject(ConnectorObject).FTrunkName <> '') and IsTrunkFigure(TConnectorObject(ConnectorObject)) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; end; //15.01.2013 if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnectorObject.ID; if FirstConnectorObject.FHouse <> nil then PointFigureRelation.FirstPointFigure := FirstConnectorObject.FHouse.ID; PointFigureRelation.LastPointFigure := ConnectorObject.ID; if ConnectorObject.FHouse <> nil then PointFigureRelation.LastPointFigure := ConnectorObject.FHouse.ID; if ARotatePath then begin for i := CurrStepFigures.Count - 1 downto 0 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; end else begin for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; end; PointFigureRelations.Add(PointFigureRelation); //15.01.2013 - запоминаем связь на объекте if FigSearchInfo.FPointFiguresRels = nil then begin FigSearchInfo.FPointFiguresRels := TRapList.Create; FigSearchInfo.FPointFiguresRelsID := TRapList.Create; end; PointFiguresRelIdx := InsertValueToSortetRapList(Pointer(FigureToSearchInfo.ID), FigSearchInfo.FPointFiguresRelsID); if PointFiguresRelIdx <> -1 then begin OldTick := GetTickCount; FigSearchInfo.FPointFiguresRels.Insert(PointFiguresRelIdx, PointFigureRelation); TickAddRelation := TickAddRelation + GetTickCount - OldTick; end; end; end; end; procedure IncFigureTags(AFigureList: TRapList); var i: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin for i := 0 to AFigureList.Count - 1 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then begin ptrPointFigureSearchInfo := PPointFigureSearchInfo(TConnectorObject(AFigureList.List^[i]).FTagPM); ptrPointFigureSearchInfo.OrderCount := ptrPointFigureSearchInfo.OrderCount + 1; end else if TFigure(AFigureList.List^[i]) is TOrtholine then begin ptrLineFigureSearchInfo := PLineFigureSearchInfo(TOrtholine(AFigureList.List^[i]).FTagPM); ptrLineFigureSearchInfo.OrderCount := ptrLineFigureSearchInfo.OrderCount + 1; end; end; end; procedure DecFigureTags(AFigureList: TRapList); var i: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin for i := AFigureList.Count - 1 downto 0 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then begin ptrPointFigureSearchInfo := PPointFigureSearchInfo(TConnectorObject(AFigureList.List^[i]).FTagPM); if ptrPointFigureSearchInfo.OrderCount > 0 then ptrPointFigureSearchInfo.OrderCount := ptrPointFigureSearchInfo.OrderCount - 1; end; //else //if TFigure(AFigureList.List^[i]) is TOrtholine then //begin // ptrLineFigureSearchInfo := PLineFigureSearchInfo(TOrtholine(AFigureList.List^[i]).FTagPM); // if ptrLineFigureSearchInfo.OrderCount > 0 then // ptrLineFigureSearchInfo.OrderCount := ptrLineFigureSearchInfo.OrderCount - 1; //end; end; end; { procedure MarkPointObjects(AConnObject: TConnectorObject; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; ConnectedObject: TFigure; ConnectedObjectsToLine: TRapList; ConnectedObjectToLine: TFigure; ConnectedPointObjects: TRapList; ConnectedLineObject: TOrtholine; ConnectedPointObject: TConnectorObject; i, j: Integer; begin //if (AConnObject is TConnectorObject) and (AConnObject <> FirstConnector) then //begin // AddRelation(TConnectorObject(AFigure)); //end; //else begin //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AConnObject); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); ConnectedPointObjects := TRapList.Create; for i := 0 to ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects.List^[i]); if (ConnectedObject is TOrtholine) and Not PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).IsLocked then begin ConnectedLineObject := TOrtholine(ConnectedObjects.List^[i]); CurrDistance := PPointFigureSearchInfo(AConnObject.FTagPM).Distance + ConnectedLineObject.LineLength; // Получить подключенные коннекторы к линии ConnectedObjectsToLine := GetConnectedObjects(ConnectedLineObject); for j := 0 to ConnectedObjectsToLine.Count - 1 do begin ConnectedObjectToLine := TFigure(ConnectedObjectsToLine.List^[j]); if (ConnectedObjectToLine is TConnectorObject) and (ConnectedObjectToLine <> AConnObject) then begin ConnectedPointObject := TConnectorObject(ConnectedObjectToLine); //if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then // begin // // Если дистанция не определена, то определяем ее // if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then // begin // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // end // else // // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую // if (CurrDistance - PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance) > 0.01 then // begin // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // // Блокируем ранее прикрепленную кротчайшую трассу // //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // end; // ConnectedPointObjects.Add(ConnectedPointObject); // end; if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then begin // Если дистанция не определена, то определяем ее if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; end else // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую if (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance - CurrDistance) > 0.01 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // Блокируем ранее прикрепленную кротчайшую трассу //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; end; //if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then ConnectedPointObjects.Add(ConnectedPointObject); end; end; end; FreeAndNil(ConnectedObjectsToLine); end; end; // Поставить признак того, что объект был просмотрен PPointFigureSearchInfo(AConnObject.FTagPM).IsLooked := true; //*** for i := 0 to ConnectedPointObjects.Count - 1 do begin MarkPointObjects(TConnectorObject(ConnectedPointObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> ConnectedPointObjects.Free; ConnectedObjects.Free; end; end;} procedure MarkPointObjects(AConnObject: TConnectorObject; AStepIndex: Integer); var TopConObjects: TRapList; TopConObject: TConnectorObject; ConnectedObjects: TRapList; //TObjectList; ConnectedObject: TFigure; ConnectedObjectsToLine: TRapList; ConnectedObjectToLine: TFigure; ConnectedPointObjects: TRapList; ConnectedLineObject: TOrtholine; ConnectedPointObject: TConnectorObject; i, j, k: Integer; begin TopConObjects := TRapList.Create; TopConObjects.Add(AConnObject); while TopConObjects.Count > 0 do begin ConnectedPointObjects := TRapList.Create; for i := 0 to TopConObjects.Count - 1 do begin TopConObject := TConnectorObject(TopConObjects.List^[i]); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(TopConObject); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); for j := 0 to ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects.List^[j]); if (ConnectedObject is TOrtholine) and Not PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).IsLocked then begin ConnectedLineObject := TOrtholine(ConnectedObjects.List^[j]); CurrDistance := PPointFigureSearchInfo(TopConObject.FTagPM).Distance + Abs(ConnectedLineObject.LineLength); if CurrDistance < 0 then CurrDistance := 0; // Получить подключенные коннекторы к линии ConnectedObjectsToLine := GetConnectedObjects(ConnectedLineObject); for k := 0 to ConnectedObjectsToLine.Count - 1 do begin ConnectedObjectToLine := TFigure(ConnectedObjectsToLine.List^[k]); if (ConnectedObjectToLine is TConnectorObject) and (ConnectedObjectToLine <> TopConObject) then begin ConnectedPointObject := TConnectorObject(ConnectedObjectToLine); //if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then if (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine = nil) or (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine is TOrtholine) then begin // Если дистанция не определена, то определяем ее if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // Если вершина м-э, то учитываем то, что мы сразу попадаем на сп, минуя вершину на др. листе, //if ((TopConObject.FConnRaiseType = crt_BetweenFloorUp) or // (TopConObject.FConnRaiseType = crt_BetweenFloorDown)) then // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := PPointFigureSearchInfo(TopConObject.FTagPM).RelatedLine; end else begin // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую if (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance - CurrDistance) > cnstCmpLenDelta then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // Блокируем ранее прикрепленную кротчайшую трассу //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // Если вершина м-э, то учитываем то, что мы сразу попадаем на сп, минуя вершину на др. листе, //if ((TopConObject.FConnRaiseType = crt_BetweenFloorUp) or // (TopConObject.FConnRaiseType = crt_BetweenFloorDown)) then // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := PPointFigureSearchInfo(TopConObject.FTagPM).RelatedLine; // Если объект был просмотрен до этово момента, но имел дольший путь, то включаем его в повторный просмотр if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then if ConnectedPointObjects.IndexOf(ConnectedPointObject) = -1 then ConnectedPointObjects.Add(ConnectedPointObject); end; end; if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then if ConnectedPointObjects.IndexOf(ConnectedPointObject) = -1 then ConnectedPointObjects.Add(ConnectedPointObject); end; end; end; FreeAndNil(ConnectedObjectsToLine); end else if (ConnectedObject is TConnectorObject) then begin ConnectedPointObject := TConnectorObject(ConnectedObject); if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := TopConObject; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := PPointFigureSearchInfo(TopConObject.FTagPM).Distance; if ConnectedPointObjects.IndexOf(ConnectedPointObject) = -1 then ConnectedPointObjects.Add(ConnectedPointObject); end; end; end; // Поставить признак того, что объект был просмотрен PPointFigureSearchInfo(TopConObject.FTagPM).IsLooked := true; ////*** // for i := 0 to ConnectedPointObjects.Count - 1 do // begin // MarkPointObjects(TConnectorObject(ConnectedPointObjects.List^[i]), AStepIndex+1); // end; // //*** <Тело рекурсии/> ConnectedObjects.Free; end; //*** //MarkPointObjects(ConnectedPointObjects, AStepIndex+1); //*** <Тело рекурсии/> TopConObjects.Clear; TopConObjects.Assign(ConnectedPointObjects); ConnectedPointObjects.Free; end; TopConObjects.Free; end; procedure SearchObjects(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and //(TConnectorObject(AFigure).ConnectorType <> ct_Clear) and (AFigure <> FirstConnector) and (TConnectorObject(AFigure).FConnRaiseType <> crt_BetweenFloorUp) and (TConnectorObject(AFigure).FConnRaiseType <> crt_BetweenFloorDown) and (TConnectorObject(AFigure).FConnRaiseType <> crt_TrunkUp) and (TConnectorObject(AFigure).FConnRaiseType <> crt_TrunkDown) then begin AddRelation(TConnectorObject(AFigure), false); end; begin //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Выкинуть объекты, которые нах. в очереди {i := ConnectedObjects.Count - 1; while i >= 0 do begin ConnectedObject := TFigure(ConnectedObjects.List^[i]); if ConnectedObject is TConnectorObject then begin if PPointFigureSearchInfo(TConnectorObject(ConnectedObject).FTagPM).OrderCount > 0 then ConnectedObjects.Delete(i); end else if ConnectedObject is TOrthoLine then if PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).OrderCount > 0 then ConnectedObjects.Delete(i); i := i - 1; end; } if ConnectedObjects.Count > 0 then begin if AFigure is TOrthoLine then CurrStepFigures.Add(AFigure); //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.AddList(ConnectedObjects); // Запомнить очередь в тагах IncFigureTags(ConnectedObjects); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); SearchObjects(TFigure(ConnectedObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.DeleteRange(FiguresInOrder.Count - ConnectedObjects.Count, ConnectedObjects.Count); DecFigureTags(ConnectedObjects); if AFigure is TOrthoLine then CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; ConnectedObjects.Free; end; end; procedure SearchPathsToPoints(AConnObject: TConnectorObject); var EndConnObject: TConnectorObject; BeginConnObject: TConnectorObject; PrevConnObject: TConnectorObject; CurrConnObject: TConnectorObject; RelatedTrace: TOrtholine; ConnectedObjectsToTrace: TRapList; ConnectedObjectToTrace: TFigure; i, j: Integer; begin for i := 0 to PointFiguresAll.Count - 1 do begin EndConnObject := TConnectorObject(PointFiguresAll.List^[i]); if EndConnObject <> AConnObject then begin BeginConnObject := nil; CurrStepFigures.Clear; CurrConnObject := EndConnObject; PrevConnObject := nil; while CurrConnObject <> nil do begin if PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine <> nil then begin if PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine is TOrthoLine then begin RelatedTrace := TOrthoLine(PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine); if CurrStepFigures.IndexOf(RelatedTrace) = -1 then begin CurrStepFigures.Add(RelatedTrace); ConnectedObjectsToTrace := GetConnectedObjects(RelatedTrace); PrevConnObject := CurrConnObject; for j := 0 to ConnectedObjectsToTrace.Count - 1 do begin ConnectedObjectToTrace := TFigure(ConnectedObjectsToTrace.List^[j]); if ConnectedObjectToTrace is TConnectorObject then if (ConnectedObjectToTrace <> EndConnObject) {and // Чтобы через вершину м-э прехода не вернуться назад (TConnectorObject(ConnectedObjectToTrace).FConnRaiseType <> crt_BetweenFloorUp) and (TConnectorObject(ConnectedObjectToTrace).FConnRaiseType <> crt_BetweenFloorDown)} then begin if ConnectedObjectToTrace = AConnObject then begin BeginConnObject := TConnectorObject(ConnectedObjectToTrace); Break; //// BREAK //// end else if ConnectedObjectToTrace <> PrevConnObject then CurrConnObject := TConnectorObject(ConnectedObjectToTrace); end; end; // Если добрались до начального объекта if BeginConnObject <> nil then begin AddRelation(EndConnObject, true); Break; //// BREAK //// end else //Если не найден новый точ-й объект, то выходим из цикла if CurrConnObject = PrevConnObject then CurrConnObject := nil; ConnectedObjectsToTrace.Free; end else CurrConnObject := nil; end else if PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine is TConnectorObject then begin PrevConnObject := CurrConnObject; CurrConnObject := TConnectorObject(PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine); end else CurrConnObject := nil; end else CurrConnObject := nil; end; end; end; end; procedure CreateTags; var i, j, k: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; CntConn, CntLine: Integer; begin try {//13.06.2013 CntConn := 0; CntLine := 0; for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin Inc(CntConn); GetZeroMem(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); TConnectorObject(CurrFigure).FTagPM := Integer(ptrPointFigureSearchInfo); ptrPointFigureSearchInfo.FPointFiguresRels := nil; //15.01.2013 ptrPointFigureSearchInfo.FPointFiguresRelsID := nil; //15.01.2013 // Ищем связанный комплексный объект для соединителя if TConnectorObject(CurrFigure).ConnectorType = ct_Clear then begin if TConnectorObject(CurrFigure).FHouse <> nil then ptrPointFigureSearchInfo.ComplexObject := TConnectorObject(CurrFigure).FHouse else // Ищем связанный магистральный объект for k := 0 to TConnectorObject(CurrFigure).JoinedConnectorsList.Count - 1 do begin ConnectedToFigure := TFigure(TConnectorObject(CurrFigure).JoinedConnectorsList[k]); if ConnectedToFigure is TConnectorObject then if TConnectorObject(ConnectedToFigure).FTrunkName <> '' then begin ptrPointFigureSearchInfo.ComplexObject := ConnectedToFigure; end; end; end; if (TConnectorObject(CurrFigure).ConnectorType <> ct_Clear) or //(ConnectorsFromTrunk.IndexOf(CurrFigure) <> -1) (ptrPointFigureSearchInfo.ComplexObject <> nil) then PointFiguresAll.Add(CurrFigure); end else if CurrFigure is TOrthoLine then begin Inc(CntLine); GetZeroMem(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); TOrthoLine(CurrFigure).FTagPM := Integer(ptrLineFigureSearchInfo); end; end; end; CntConn := 0; CntLine := 0;} //13.06.2013 Выбираем все объекты учитывая сгруппированные ProjPointFigures := GetAllFiguresByClassFromProj(TConnectorObject); for i := 0 to ProjPointFigures.Count - 1 do begin CurrFigure := TFigure(ProjPointFigures[i]); GetZeroMem(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); TConnectorObject(CurrFigure).FTagPM := Integer(ptrPointFigureSearchInfo); ptrPointFigureSearchInfo.FPointFiguresRels := nil; //15.01.2013 ptrPointFigureSearchInfo.FPointFiguresRelsID := nil; //15.01.2013 // Ищем связанный комплексный объект для соединителя if TConnectorObject(CurrFigure).ConnectorType = ct_Clear then begin if TConnectorObject(CurrFigure).FHouse <> nil then ptrPointFigureSearchInfo.ComplexObject := TConnectorObject(CurrFigure).FHouse else // Ищем связанный магистральный объект for k := 0 to TConnectorObject(CurrFigure).JoinedConnectorsList.Count - 1 do begin ConnectedToFigure := TFigure(TConnectorObject(CurrFigure).JoinedConnectorsList[k]); if ConnectedToFigure is TConnectorObject then if TConnectorObject(ConnectedToFigure).FTrunkName <> '' then begin ptrPointFigureSearchInfo.ComplexObject := ConnectedToFigure; end; end; end; if (TConnectorObject(CurrFigure).ConnectorType <> ct_Clear) or //(ConnectorsFromTrunk.IndexOf(CurrFigure) <> -1) (ptrPointFigureSearchInfo.ComplexObject <> nil) then PointFiguresAll.Add(CurrFigure); end; ProjLineFigures := GetAllFiguresByClassFromProj(TOrthoLine); for i := 0 to ProjLineFigures.Count - 1 do begin CurrFigure := TFigure(ProjLineFigures[i]); GetZeroMem(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); TOrthoLine(CurrFigure).FTagPM := Integer(ptrLineFigureSearchInfo); end; except on E: Exception do AddExceptionToLogEx('CreateTags', E.Message); end; end; procedure FreeTags; var i, j: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin {//13.06.2013 for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); if ptrPointFigureSearchInfo.FPointFiguresRels <> nil then //15.01.2013 begin ptrPointFigureSearchInfo.FPointFiguresRels.Free; ptrPointFigureSearchInfo.FPointFiguresRelsID.Free; end; FreeMem(ptrPointFigureSearchInfo); TConnectorObject(CurrFigure).FTagPM := 0; end else if CurrFigure is TOrthoLine then begin ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); FreeMem(ptrLineFigureSearchInfo); TOrthoLine(CurrFigure).FTagPM := 0; end; end; end;} //13.06.2013 Обрабатываем все объекты учитывая сгруппированные for i := 0 to ProjPointFigures.Count - 1 do begin CurrFigure := TFigure(ProjPointFigures[i]); ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); if ptrPointFigureSearchInfo.FPointFiguresRels <> nil then //15.01.2013 begin ptrPointFigureSearchInfo.FPointFiguresRels.Free; ptrPointFigureSearchInfo.FPointFiguresRelsID.Free; end; FreeMem(ptrPointFigureSearchInfo); TConnectorObject(CurrFigure).FTagPM := 0; end; for i := 0 to ProjLineFigures.Count - 1 do begin CurrFigure := TFigure(ProjLineFigures[i]); ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); FreeMem(ptrLineFigureSearchInfo); TOrthoLine(CurrFigure).FTagPM := 0; end; FreeAndNil(ProjPointFigures); FreeAndNil(ProjLineFigures); end; procedure ClearAllFigureTags; var i, j: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; SavedComplexObject: TObject; SavedFPointFiguresRels: TRapList; SavedFPointFiguresRelsID: TRapList; begin try {//13.06.2013 for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); SavedComplexObject := ptrPointFigureSearchInfo.ComplexObject; SavedFPointFiguresRels := ptrPointFigureSearchInfo.FPointFiguresRels; SavedFPointFiguresRelsID := ptrPointFigureSearchInfo.FPointFiguresRelsID; ZeroMemory(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); ptrPointFigureSearchInfo.ComplexObject := SavedComplexObject; ptrPointFigureSearchInfo.FPointFiguresRels := SavedFPointFiguresRels; ptrPointFigureSearchInfo.FPointFiguresRelsID := SavedFPointFiguresRelsID; ptrPointFigureSearchInfo.Distance := -1; ptrPointFigureSearchInfo.RelatedLine := nil; ptrPointFigureSearchInfo.IsLooked := false; ptrPointFigureSearchInfo.OrderCount := 0; end else if CurrFigure is TOrthoLine then begin ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); ZeroMemory(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); ptrLineFigureSearchInfo.IsLocked := false; ptrLineFigureSearchInfo.OrderCount := 0; end; end; end;} //13.06.2013 Выбираем все объекты учитывая сгруппированные for i := 0 to ProjPointFigures.Count - 1 do begin CurrFigure := TFigure(ProjPointFigures[i]); ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); SavedComplexObject := ptrPointFigureSearchInfo.ComplexObject; SavedFPointFiguresRels := ptrPointFigureSearchInfo.FPointFiguresRels; SavedFPointFiguresRelsID := ptrPointFigureSearchInfo.FPointFiguresRelsID; ZeroMemory(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); ptrPointFigureSearchInfo.ComplexObject := SavedComplexObject; ptrPointFigureSearchInfo.FPointFiguresRels := SavedFPointFiguresRels; ptrPointFigureSearchInfo.FPointFiguresRelsID := SavedFPointFiguresRelsID; ptrPointFigureSearchInfo.Distance := -1; ptrPointFigureSearchInfo.RelatedLine := nil; ptrPointFigureSearchInfo.IsLooked := false; ptrPointFigureSearchInfo.OrderCount := 0; end; for i := 0 to ProjLineFigures.Count - 1 do begin CurrFigure := TFigure(ProjLineFigures[i]); ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); ZeroMemory(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); ptrLineFigureSearchInfo.IsLocked := false; ptrLineFigureSearchInfo.OrderCount := 0; end; except on E: Exception do AddExceptionToLogEx('ClearAllFigureTags', E.Message); end; end; begin Result := nil; try PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; TickAddRelation := 0; List := GetListByID(AIDList); if List <> nil then begin PointFiguresAll := TRapList.Create; PointFigures := TObjectList.Create(false); CurrPointFigures := TRapList.Create; CurrStepFigures := TRapList.Create; //FiguresInOrder := TRapList.Create; FiguresWithFindedConnections := TRapList.Create; ListOfListConnectedObjects := TRapList.Create; //ConnectorsFromTrunk := TRapList.Create; //TrunksForConnectors := TRapList.Create; CountOfGetConnectedObjectsFromFinded := 0; //// Сбросить таги //DropAllFigureTags; // Отобрать все точ-е объекты с текущего листа //13.06.2013 //for i := 0 to List.PCad.FigureCount - 1 do //begin // CurrFigure := TFigure(List.PCad.Figures[i]); // if CurrFigure is TConnectorObject then AllPointFigures := GetAllFiguresByClass(List, TConnectorObject); //13.06.2013 for i := 0 to AllPointFigures.Count - 1 do begin CurrFigure := TConnectorObject(AllPointFigures[i]); begin if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then begin if TConnectorObject(CurrFigure).FTrunkName = '' then PointFigures.Add(CurrFigure); end else begin if TConnectorObject(CurrFigure).FHouse <> nil then PointFigures.Add(CurrFigure) else for j := 0 to TConnectorObject(CurrFigure).JoinedConnectorsList.Count - 1 do begin ConnectedToFigure := TFigure(TConnectorObject(CurrFigure).JoinedConnectorsList[j]); if ConnectedToFigure is TConnectorObject then if TConnectorObject(ConnectedToFigure).FTrunkName <> '' then begin PointFigures.Add(CurrFigure); //ConnectorsFromTrunk.Add(CurrFigure); //TrunksForConnectors.Add(ConnectedToFigure); end; end; end; end; end; FreeAndNil(AllPointFigures); CreateTags; try for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; //FiguresInOrder.Clear; //FiguresInOrder.Add(FirstConnector); // Сбросить таги ClearAllFigureTags; // промаркировать объекты - отметиь отсеченные трассы PPointFigureSearchInfo(FirstConnector.FTagPM).Distance := 0; MarkPointObjects(FirstConnector, 0); //CurrPointFigures.Clear; //CurrPointFigures.Add(FirstConnector); //MarkPointObjects(CurrPointFigures, 0); // поиск по неотсеченным трассам SearchPathsToPoints(FirstConnector); //PPointFigureSearchInfo(FirstConnector.FTagPM).OrderCount := 1; //SearchObjects(FirstConnector, 0); end; finally FreeTags; end; TickAddRelation := TickAddRelation; //FreeAndNil(TrunksForConnectors); //FreeAndNil(ConnectorsFromTrunk); //ListOfListConnectedObjects.ClearOwnObjects; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); //FreeAndNil(FiguresInOrder); FreeAndNil(CurrPointFigures); FreeAndNil(PointFigures); FreeAndNil(PointFiguresAll); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; except on E: Exception do AddExceptionToLogEx('GetPointObjectRelationsBetweenListDistr', E.Message); end; end; function GetListsIDRelatedToFigures(ACurrListID: Integer; AFiguresID: TIntList): TIntList; var SCSList: TSCSList; SCSObjects: TSCSCatalogs; SCSObject: TSCSCatalog; i: Integer; RelatedLists: TIntList; begin Result := TIntList.Create; try SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(ACurrListID); if SCSList <> nil then begin SCSObjects := TSCSCatalogs.Create(false); // Составляем список объектов for i := 0 to AFiguresID.Count - 1 do begin SCSObject := SCSList.GetCatalogFromReferencesBySCSID(AFiguresID[i]); if SCSObject <> nil then SCSObjects.Add(SCSObject); end; RelatedLists := GetVariousListsIDsByObjects(SCSObjects, true); Result.Assign(RelatedLists); FreeAndNil(RelatedLists); end; FreeAndNil(SCSObjects); except on E: Exception do AddExceptionToLogEx('GetListsIDRelatedToFigures', E.Message); end; FreeAndNil(AFiguresID); end; procedure SetStatusFilteredConnectedObjToCAD(AIDList: Integer); var CADList: TF_CAD; i: Integer; FilterInfoConn: TFilterInfo; FilterInfoLine: TFilterInfo; ConnImageIndex: Integer; LineImageIndex: Integer; {procedure SetStarusToList(AList: TF_CAD); begin end;} begin FilterInfoConn := F_ProjMan.GSCSBase.CurrProject.GetFilterInfoByType(ftConnectedConObjects); FilterInfoLine := F_ProjMan.GSCSBase.CurrProject.GetFilterInfoByType(ftConnectedLineCompons); ConnImageIndex := 140; LineImageIndex := 97; if FilterInfoConn <> nil then if FilterInfoConn.UseInCAD then ConnImageIndex := 181; if FilterInfoLine <> nil then if FilterInfoLine.UseInCAD then LineImageIndex := 182; FSCS_Main.aShowConnFullness.ImageIndex := ConnImageIndex; FSCS_Main.aShowCableFullness.ImageIndex := LineImageIndex; {if AIDList = 0 then begin CADList := GetListByID(AIDList); end else begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CADList := TF_CAD(FSCS_Main.MDIChildren[i]); end; end;} end; (* function GetPointObjectRelationsBetweenListDistr(AIDList: Integer): TObjectList; var List: TF_CAD; CurrList: TForm; PointFigureRelations: TObjectList; PointFiguresAll: TRapList; PointFigures: TObjectList; CurrPointFigures: TRapList; CurrFigure: TFigure; CurrStepFigures: TRapList; //FiguresInOrder: TRapList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TRapList; ListOfListConnectedObjects: TRapList; CurrDistance: Double; TotalTick: Cardinal; OldTick: Cardinal; GetCount: Integer; CountOfGetConnectedObjectsFromFinded: Integer; i, j: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TRapList); var ConnectedFigures: TRapList; begin ConnectedFigures := TRapList.Create; ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; { function GetConnectedObjectsFromFinded(AFigure: TFigure): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; i: Integer; begin Result := nil; //CountOfGetConnectedObjectsFromFinded := CountOfGetConnectedObjectsFromFinded + 1; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TRapList.Create; ConnectedFigures := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //Result.Assign(ConnectedFigures); for i := 0 to ConnectedFigures.Count - 1 do begin if FiguresInOrder.IndexOf(ConnectedFigures.List^[i]) = -1 then Result.Add(ConnectedFigures.List^[i]); end; end; end;} //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам //if Result = nil then if IndexFigure = -1 then begin 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])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; end else begin FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(nil); end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TRapList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TRapList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; try if Result = nil then begin Result := TRapList.Create; if AFigure is TConnectorObject then begin ConnRaiseType := TConnectorObject(AFigure).FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then begin ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(TConnectorObject(AFigure)); if ConnectedObjectsFromBetweenFloorConnector <> nil then for i := 0 to ConnectedObjectsFromBetweenFloorConnector.Count - 1 do begin FigureToResult := TFigure(ConnectedObjectsFromBetweenFloorConnector.List^[i]); if FigureToResult is TOrtholine then if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end; end else //if TConnectorObject(AFigure).ConnectorType = ct_Clear then begin if TConnectorObject(AFigure).JoinedConnectorsList.Count > 0 then begin 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]); if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end; end; end; //else 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]); if Not PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).IsLocked then if PLineFigureSearchInfo(TOrthoLine(FigureToResult).FTagPM).OrderCount = 0 then begin Result.Add(FigureToResult); end; end; 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 if PPointFigureSearchInfo(ConnObject.FTagPM).OrderCount = 0 then Result.Add(ConnObject); end else begin // Если к коннетору не подключены точ. объекты if ConnObject.JoinedConnectorsList.Count = 0 then begin if PPointFigureSearchInfo(ConnObject.FTagPM).OrderCount = 0 then Result.Add(ConnObject); end else for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if PPointFigureSearchInfo(TConnectorObject(FigureToResult).FTagPM).OrderCount = 0 then Result.Add(FigureToResult); end; end; { 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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end;} // Сторона 2 ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector2); ConnRaiseType := ConnObject.FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then begin Result.Add(ConnObject); end else begin // Если к коннетору не подключены точ. объекты if ConnObject.JoinedConnectorsList.Count = 0 then Result.Add(ConnObject) else for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); Result.Add(FigureToResult); end; end; {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 //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TOrthoLine(FigureToResult).FTagPM = 0 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 //if FiguresInOrder.IndexOf(JoinedLine) = -1 then if JoinedLine.FTagPM = 0 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); //if FiguresInOrder.IndexOf(FigureToResult) = -1 then if TConnectorObject(FigureToResult).FTagPM = 0 then begin Result.Add(FigureToResult); end; end; end;} end; { // Добавить в список подключаемых AddConnectedObjectsToFinded(AFigure, Result); // Выкинуть оюъекты, которые находятся в очереди i := Result.Count - 1; while i >= 0 do begin if FiguresInOrder.IndexOf(Result.List^[i]) <> -1 then Result.Delete(i); i := i-1; end;} end; except on E: Exception do AddExceptionToLogEx('GetPointObjectRelationsBetweenListDistr:GetConnectedObjects', E.Message); end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if AConnector.FTrunkName <> '' then if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TRapList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure AddRelation(AConnectorObject: TConnectorObject; ARotatePath: Boolean); var RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations.List^[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AConnectorObject.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали //FirstTraceID := -1; //LastTraceID := -1; if (PointFigureRelation.Traces.List.Count >= 2) and (CurrStepFigures.Count >= 2) then begin //FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); //LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); //if CheckedAsReverse then // ExchangeIntegers(FirstTraceID, LastTraceID); if (FirstConnector.FTrunkName <> '') and IsTrunkFigure(FirstConnector) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if (TConnectorObject(AConnectorObject).FTrunkName <> '') and IsTrunkFigure(TConnectorObject(AConnectorObject)) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AConnectorObject.ID; if ARotatePath then begin for i := CurrStepFigures.Count - 1 downto 0 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; end else begin for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; end; PointFigureRelations.Add(PointFigureRelation); end; end; procedure IncFigureTags(AFigureList: TRapList); var i: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin for i := 0 to AFigureList.Count - 1 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then begin ptrPointFigureSearchInfo := PPointFigureSearchInfo(TConnectorObject(AFigureList.List^[i]).FTagPM); ptrPointFigureSearchInfo.OrderCount := ptrPointFigureSearchInfo.OrderCount + 1; end else if TFigure(AFigureList.List^[i]) is TOrtholine then begin ptrLineFigureSearchInfo := PLineFigureSearchInfo(TOrtholine(AFigureList.List^[i]).FTagPM); ptrLineFigureSearchInfo.OrderCount := ptrLineFigureSearchInfo.OrderCount + 1; end; end; end; procedure DecFigureTags(AFigureList: TRapList); var i: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin for i := AFigureList.Count - 1 downto 0 do begin if TFigure(AFigureList.List^[i]) is TConnectorObject then begin ptrPointFigureSearchInfo := PPointFigureSearchInfo(TConnectorObject(AFigureList.List^[i]).FTagPM); if ptrPointFigureSearchInfo.OrderCount > 0 then ptrPointFigureSearchInfo.OrderCount := ptrPointFigureSearchInfo.OrderCount - 1; end; //else //if TFigure(AFigureList.List^[i]) is TOrtholine then //begin // ptrLineFigureSearchInfo := PLineFigureSearchInfo(TOrtholine(AFigureList.List^[i]).FTagPM); // if ptrLineFigureSearchInfo.OrderCount > 0 then // ptrLineFigureSearchInfo.OrderCount := ptrLineFigureSearchInfo.OrderCount - 1; //end; end; end; { procedure MarkPointObjects(AConnObject: TConnectorObject; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; ConnectedObject: TFigure; ConnectedObjectsToLine: TRapList; ConnectedObjectToLine: TFigure; ConnectedPointObjects: TRapList; ConnectedLineObject: TOrtholine; ConnectedPointObject: TConnectorObject; i, j: Integer; begin //if (AConnObject is TConnectorObject) and (AConnObject <> FirstConnector) then //begin // AddRelation(TConnectorObject(AFigure)); //end; //else begin //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AConnObject); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); ConnectedPointObjects := TRapList.Create; for i := 0 to ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects.List^[i]); if (ConnectedObject is TOrtholine) and Not PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).IsLocked then begin ConnectedLineObject := TOrtholine(ConnectedObjects.List^[i]); CurrDistance := PPointFigureSearchInfo(AConnObject.FTagPM).Distance + ConnectedLineObject.LineLength; // Получить подключенные коннекторы к линии ConnectedObjectsToLine := GetConnectedObjects(ConnectedLineObject); for j := 0 to ConnectedObjectsToLine.Count - 1 do begin ConnectedObjectToLine := TFigure(ConnectedObjectsToLine.List^[j]); if (ConnectedObjectToLine is TConnectorObject) and (ConnectedObjectToLine <> AConnObject) then begin ConnectedPointObject := TConnectorObject(ConnectedObjectToLine); //if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then // begin // // Если дистанция не определена, то определяем ее // if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then // begin // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // end // else // // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую // if (CurrDistance - PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance) > 0.01 then // begin // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // // Блокируем ранее прикрепленную кротчайшую трассу // //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; // PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // end; // ConnectedPointObjects.Add(ConnectedPointObject); // end; if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then begin // Если дистанция не определена, то определяем ее if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; end else // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую if (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance - CurrDistance) > 0.01 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // Блокируем ранее прикрепленную кротчайшую трассу //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; end; //if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then ConnectedPointObjects.Add(ConnectedPointObject); end; end; end; FreeAndNil(ConnectedObjectsToLine); end; end; // Поставить признак того, что объект был просмотрен PPointFigureSearchInfo(AConnObject.FTagPM).IsLooked := true; //*** for i := 0 to ConnectedPointObjects.Count - 1 do begin MarkPointObjects(TConnectorObject(ConnectedPointObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> ConnectedPointObjects.Free; ConnectedObjects.Free; end; end;} procedure MarkPointObjects(AConnObject: TConnectorObject; AStepIndex: Integer); var TopConObjects: TRapList; TopConObject: TConnectorObject; ConnectedObjects: TRapList; //TObjectList; ConnectedObject: TFigure; ConnectedObjectsToLine: TRapList; ConnectedObjectToLine: TFigure; ConnectedPointObjects: TRapList; ConnectedLineObject: TOrtholine; ConnectedPointObject: TConnectorObject; i, j, k: Integer; begin //if (AConnObject is TConnectorObject) and (AConnObject <> FirstConnector) then //begin // AddRelation(TConnectorObject(AFigure)); //end; //else TopConObjects := TRapList.Create; TopConObjects.Add(AConnObject); while TopConObjects.Count > 0 do begin ConnectedPointObjects := TRapList.Create; for i := 0 to TopConObjects.Count - 1 do begin TopConObject := TConnectorObject(TopConObjects.List^[i]); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(TopConObject); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); for j := 0 to ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects.List^[j]); if (ConnectedObject is TOrtholine) and Not PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).IsLocked then begin ConnectedLineObject := TOrtholine(ConnectedObjects.List^[j]); CurrDistance := PPointFigureSearchInfo(TopConObject.FTagPM).Distance + ConnectedLineObject.LineLength; // Получить подключенные коннекторы к линии ConnectedObjectsToLine := GetConnectedObjects(ConnectedLineObject); for k := 0 to ConnectedObjectsToLine.Count - 1 do begin ConnectedObjectToLine := TFigure(ConnectedObjectsToLine.List^[k]); if (ConnectedObjectToLine is TConnectorObject) and (ConnectedObjectToLine <> TopConObject) then begin ConnectedPointObject := TConnectorObject(ConnectedObjectToLine); if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then begin // Если дистанция не определена, то определяем ее if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance = -1 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // Если вершина м-э, то учитываем то, что мы сразу попадаем на сп, минуя вершину на др. листе, if ((TopConObject.FConnRaiseType = crt_BetweenFloorUp) or (TopConObject.FConnRaiseType = crt_BetweenFloorDown)) {and ((ConnectedPointObject.FConnRaiseType = crt_BetweenFloorUp) or (ConnectedPointObject.FConnRaiseType = crt_BetweenFloorDown))} then PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := PPointFigureSearchInfo(TopConObject.FTagPM).RelatedLine; end else // Если ранее найденная дистанция меньше текущей, то устанавливаем текущую if (PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance - CurrDistance) > 0.01 then begin PPointFigureSearchInfo(ConnectedPointObject.FTagPM).Distance := CurrDistance; // Блокируем ранее прикрепленную кротчайшую трассу //if PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine <> nil then // PLineFigureSearchInfo(TOrthoLine(PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine).FTagPM).IsLocked := true; PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := ConnectedLineObject; // Если вершина м-э, то учитываем то, что мы сразу попадаем на сп, минуя вершину на др. листе, if ((TopConObject.FConnRaiseType = crt_BetweenFloorUp) or (TopConObject.FConnRaiseType = crt_BetweenFloorDown)) {and ((ConnectedPointObject.FConnRaiseType = crt_BetweenFloorUp) or (ConnectedPointObject.FConnRaiseType = crt_BetweenFloorDown))} then PPointFigureSearchInfo(ConnectedPointObject.FTagPM).RelatedLine := PPointFigureSearchInfo(TopConObject.FTagPM).RelatedLine; end; if Not PPointFigureSearchInfo(ConnectedPointObject.FTagPM).IsLooked then ConnectedPointObjects.Add(ConnectedPointObject); end; end; end; FreeAndNil(ConnectedObjectsToLine); end; end; // Поставить признак того, что объект был просмотрен PPointFigureSearchInfo(TopConObject.FTagPM).IsLooked := true; ////*** // for i := 0 to ConnectedPointObjects.Count - 1 do // begin // MarkPointObjects(TConnectorObject(ConnectedPointObjects.List^[i]), AStepIndex+1); // end; // //*** <Тело рекурсии/> ConnectedObjects.Free; end; //*** //MarkPointObjects(ConnectedPointObjects, AStepIndex+1); //*** <Тело рекурсии/> TopConObjects.Clear; TopConObjects.Assign(ConnectedPointObjects); ConnectedPointObjects.Free; end; TopConObjects.Free; end; procedure SearchObjects(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and (TConnectorObject(AFigure).ConnectorType <> ct_Clear) and (AFigure <> FirstConnector) and (TConnectorObject(AFigure).FConnRaiseType <> crt_BetweenFloorUp) and (TConnectorObject(AFigure).FConnRaiseType <> crt_BetweenFloorDown) then begin AddRelation(TConnectorObject(AFigure), false); end; begin //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Выкинуть объекты, которые нах. в очереди {i := ConnectedObjects.Count - 1; while i >= 0 do begin ConnectedObject := TFigure(ConnectedObjects.List^[i]); if ConnectedObject is TConnectorObject then begin if PPointFigureSearchInfo(TConnectorObject(ConnectedObject).FTagPM).OrderCount > 0 then ConnectedObjects.Delete(i); end else if ConnectedObject is TOrthoLine then if PLineFigureSearchInfo(TOrthoLine(ConnectedObject).FTagPM).OrderCount > 0 then ConnectedObjects.Delete(i); i := i - 1; end; } if ConnectedObjects.Count > 0 then begin if AFigure is TOrthoLine then CurrStepFigures.Add(AFigure); //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.AddList(ConnectedObjects); // Запомнить очередь в тагах IncFigureTags(ConnectedObjects); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); SearchObjects(TFigure(ConnectedObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.DeleteRange(FiguresInOrder.Count - ConnectedObjects.Count, ConnectedObjects.Count); DecFigureTags(ConnectedObjects); if AFigure is TOrthoLine then CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; ConnectedObjects.Free; end; end; procedure SearchPathsToPoints(AConnObject: TConnectorObject); var EndConnObject: TConnectorObject; BeginConnObject: TConnectorObject; PrevConnObject: TConnectorObject; CurrConnObject: TConnectorObject; RelatedTrace: TOrtholine; ConnectedObjectsToTrace: TRapList; ConnectedObjectToTrace: TFigure; i, j: Integer; begin for i := 0 to PointFiguresAll.Count - 1 do begin EndConnObject := TConnectorObject(PointFiguresAll.List^[i]); if EndConnObject <> AConnObject then begin BeginConnObject := nil; CurrStepFigures.Clear; CurrConnObject := EndConnObject; PrevConnObject := nil; while CurrConnObject <> nil do begin if PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine <> nil then begin RelatedTrace := TOrthoLine(PPointFigureSearchInfo(CurrConnObject.FTagPM).RelatedLine); if CurrStepFigures.IndexOf(RelatedTrace) = -1 then begin CurrStepFigures.Add(RelatedTrace); ConnectedObjectsToTrace := GetConnectedObjects(RelatedTrace); PrevConnObject := CurrConnObject; for j := 0 to ConnectedObjectsToTrace.Count - 1 do begin ConnectedObjectToTrace := TFigure(ConnectedObjectsToTrace.List^[j]); if ConnectedObjectToTrace is TConnectorObject then if (ConnectedObjectToTrace <> EndConnObject) and // Чтобы через вершину м-э прехода не вернуться назад (TConnectorObject(ConnectedObjectToTrace).FConnRaiseType <> crt_BetweenFloorUp) and (TConnectorObject(ConnectedObjectToTrace).FConnRaiseType <> crt_BetweenFloorDown) then begin if ConnectedObjectToTrace = AConnObject then begin BeginConnObject := TConnectorObject(ConnectedObjectToTrace); Break; //// BREAK //// end else if ConnectedObjectToTrace <> PrevConnObject then CurrConnObject := TConnectorObject(ConnectedObjectToTrace); end; end; // Если добрались до начального объекта if BeginConnObject <> nil then begin AddRelation(EndConnObject, true); Break; //// BREAK //// end else //Если не найден новый точ-й объект, то выходим из цикла if CurrConnObject = PrevConnObject then CurrConnObject := nil; ConnectedObjectsToTrace.Free; end else CurrConnObject := nil; end else CurrConnObject := nil; end; end; end; end; procedure CreateTags; var i, j: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin GetZeroMem(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); TConnectorObject(CurrFigure).FTagPM := Integer(ptrPointFigureSearchInfo); if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFiguresAll.Add(CurrFigure); end else if CurrFigure is TOrthoLine then begin GetZeroMem(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); TOrthoLine(CurrFigure).FTagPM := Integer(ptrLineFigureSearchInfo); end; end; end; except on E: Exception do AddExceptionToLogEx('CreateTags', E.Message); end; end; procedure FreeTags; var i, j: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); FreeMem(ptrPointFigureSearchInfo); TConnectorObject(CurrFigure).FTagPM := 0; end else if CurrFigure is TOrthoLine then begin ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); FreeMem(ptrLineFigureSearchInfo); TOrthoLine(CurrFigure).FTagPM := 0; end; end; end; end; procedure ClearAllFigureTags; var i, j: Integer; ptrPointFigureSearchInfo: PPointFigureSearchInfo; ptrLineFigureSearchInfo: PLineFigureSearchInfo; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurrList := FSCS_Main.MDIChildren[i]; if CurrList is TF_CAD then for j := 0 to TF_CAD(CurrList).PCad.FigureCount - 1 do begin CurrFigure := TFigure(TF_CAD(CurrList).PCad.Figures[j]); if CurrFigure is TConnectorObject then begin ptrPointFigureSearchInfo := Pointer(TConnectorObject(CurrFigure).FTagPM); ZeroMemory(ptrPointFigureSearchInfo, SizeOf(TPointFigureSearchInfo)); ptrPointFigureSearchInfo.Distance := -1; ptrPointFigureSearchInfo.RelatedLine := nil; ptrPointFigureSearchInfo.IsLooked := false; ptrPointFigureSearchInfo.OrderCount := 0; end else if CurrFigure is TOrthoLine then begin ptrLineFigureSearchInfo := Pointer(TOrthoLine(CurrFigure).FTagPM); ZeroMemory(ptrLineFigureSearchInfo, SizeOf(TLineFigureSearchInfo)); ptrLineFigureSearchInfo.IsLocked := false; ptrLineFigureSearchInfo.OrderCount := 0; end; end; end; except on E: Exception do AddExceptionToLogEx('ClearAllFigureTags', E.Message); end; end; begin Result := nil; try PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFiguresAll := TRapList.Create; PointFigures := TObjectList.Create(false); CurrPointFigures := TRapList.Create; CurrStepFigures := TRapList.Create; //FiguresInOrder := TRapList.Create; FiguresWithFindedConnections := TRapList.Create; ListOfListConnectedObjects := TRapList.Create; CountOfGetConnectedObjectsFromFinded := 0; //// Сбросить таги //DropAllFigureTags; // Отобрать все точ-е объекты с текущего листа for i := 0 to List.PCad.FigureCount - 1 do begin CurrFigure := TFigure(List.PCad.Figures[i]); if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; CreateTags; try for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; //FiguresInOrder.Clear; //FiguresInOrder.Add(FirstConnector); // Сбросить таги ClearAllFigureTags; // промаркировать объекты - отметиь отсеченные трассы PPointFigureSearchInfo(FirstConnector.FTagPM).Distance := 0; MarkPointObjects(FirstConnector, 0); //CurrPointFigures.Clear; //CurrPointFigures.Add(FirstConnector); //MarkPointObjects(CurrPointFigures, 0); // поиск по неотсеченным трассам SearchPathsToPoints(FirstConnector); //PPointFigureSearchInfo(FirstConnector.FTagPM).OrderCount := 1; //SearchObjects(FirstConnector, 0); end; finally FreeTags; end; ListOfListConnectedObjects.ClearOwnObjects; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); //FreeAndNil(FiguresInOrder); FreeAndNil(CurrPointFigures); FreeAndNil(PointFigures); FreeAndNil(PointFiguresAll); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; except on E: Exception do AddExceptionToLogEx('GetPointObjectRelationsBetweenListDistr', E.Message); end; end; *) (* // TRapLists function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; var List: TF_CAD; PointFigureRelations: TObjectList; PointFigures: TObjectList; CurrFigure: TFigure; CurrStepFigures: TRapList; FiguresInOrder: TRapList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TRapList; ListOfListConnectedObjects: TRapList; TotalTick: Cardinal; OldTick: Cardinal; GetCount: Integer; CountOfGetConnectedObjectsFromFinded: Integer; i: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TRapList); var ConnectedFigures: TRapList; begin ConnectedFigures := TRapList.Create; ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; function GetConnectedObjectsFromFinded(AFigure: TFigure): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; i: Integer; begin Result := nil; //CountOfGetConnectedObjectsFromFinded := CountOfGetConnectedObjectsFromFinded + 1; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TRapList.Create; ConnectedFigures := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //Result.Assign(ConnectedFigures); for i := 0 to ConnectedFigures.Count - 1 do begin if FiguresInOrder.IndexOf(ConnectedFigures.List^[i]) = -1 then Result.Add(ConnectedFigures.List^[i]); end; end; end; //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TRapList(ListOfListConnectedObjects.List^[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам //if Result = nil then if IndexFigure = -1 then begin 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])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; end else begin FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(nil); end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TRapList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TRapList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; if Result = nil then begin Result := TRapList.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]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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 if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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 if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; 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 if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end; end; { // Добавить в список подключаемых AddConnectedObjectsToFinded(AFigure, Result); // Выкинуть оюъекты, которые находятся в очереди i := Result.Count - 1; while i >= 0 do begin if FiguresInOrder.IndexOf(Result.List^[i]) <> -1 then Result.Delete(i); i := i-1; end;} end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if AConnector.FTrunkName <> '' then if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TRapList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList.List^[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure AddRelation(AConnectorObject: TConnectorObject); var RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations.List^[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AConnectorObject.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали //FirstTraceID := -1; //LastTraceID := -1; if (PointFigureRelation.Traces.List.Count >= 2) and (CurrStepFigures.Count >= 2) then begin //FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); //LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); //if CheckedAsReverse then // ExchangeIntegers(FirstTraceID, LastTraceID); if (FirstConnector.FTrunkName <> '') and IsTrunkFigure(FirstConnector) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if (TConnectorObject(AConnectorObject).FTrunkName <> '') and IsTrunkFigure(TConnectorObject(AConnectorObject)) then begin FirstTraceID := Integer(PointFigureRelation.Traces.List.List^[0]); LastTraceID := Integer(PointFigureRelation.Traces.List.List^[PointFigureRelation.Traces.Count - 1]); if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AConnectorObject.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures.List^[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; end; procedure Step(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TRapList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and (AFigure <> FirstConnector) then begin AddRelation(TConnectorObject(AFigure)); end; //else begin //CurrStepFigures.Add(AFigure); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Эта проверка создавала небольшие тормоза, теперь это делается в GetConnectedObjects {i := 0; while i <= ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); if FiguresInOrder.IndexOf(ConnectedObject) <> -1 then ConnectedObjects.Delete(i) else Inc(i); end;} if ConnectedObjects.Count > 0 then begin CurrStepFigures.Add(AFigure); //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); FiguresInOrder.AddList(ConnectedObjects); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); Step(TFigure(ConnectedObjects.List^[i]), AStepIndex+1); end; //*** <Тело рекурсии/> //for i := 0 to ConnectedObjects.Count - 1 do // FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); FiguresInOrder.DeleteRange(FiguresInOrder.Count - ConnectedObjects.Count, ConnectedObjects.Count); CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; ConnectedObjects.Free; //CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; begin Result := nil; PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFigures := TObjectList.Create(false); CurrStepFigures := TRapList.Create; FiguresInOrder := TRapList.Create; FiguresWithFindedConnections := TRapList.Create; ListOfListConnectedObjects := TRapList.Create; CountOfGetConnectedObjectsFromFinded := 0; for i := 0 to List.PCad.FigureCount - 1 do begin CurrFigure := TFigure(List.PCad.Figures[i]); if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; FiguresInOrder.Clear; FiguresInOrder.Add(FirstConnector); Step(FirstConnector, 0); end; ListOfListConnectedObjects.ClearOwnObjects; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); FreeAndNil(FiguresInOrder); FreeAndNil(PointFigures); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; end; *) (* //TObjectLists function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; var List: TF_CAD; PointFigureRelations: TObjectList; PointFigures: TObjectList; CurrFigure: TFigure; CurrStepFigures: TObjectList; FiguresInOrder: TObjectList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TObjectList; ListOfListConnectedObjects: TObjectList; TotalTick: Cardinal; OldTick: Cardinal; GetCount: Integer; i: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TObjectList); var ConnectedFigures: TObjectList; begin ConnectedFigures := TObjectList.Create(false); ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; function GetConnectedObjectsFromFinded(AFigure: TFigure): TObjectList; var IndexFigure: Integer; ConnectedFigures: TObjectList; begin Result := nil; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TObjectList.Create(false); ConnectedFigures := TObjectList(ListOfListConnectedObjects[IndexFigure]); Result.Assign(ConnectedFigures); end; end; //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TObjectList; var IndexFigure: Integer; ConnectedFigures: TObjectList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; //*** Найти в списке просмотренных таких связей IndexFigure := FiguresWithFindedConnections.IndexOf(AConnObject); if IndexFigure <> -1 then Result := TObjectList(ListOfListConnectedObjects[IndexFigure]); //*** Если не удалось найти выше, то ищем по объектам if Result = nil then begin ListOfPassage := GetListOfPassage(AConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, AConnObject.FID_ConnToPassage)); if ConnOfPassage <> nil then begin ConnectedFigures := TObjectList.Create(false); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do ConnectedFigures.Add(TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i])); //*** Запомнить это соединение FiguresWithFindedConnections.Add(AConnObject); ListOfListConnectedObjects.Add(ConnectedFigures); Result := ConnectedFigures; end; end; end; end; function GetConnectedObjects(AFigure: TFigure): TObjectList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; ConnectedObjectsFromBetweenFloorConnector: TObjectList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; begin //Result := GetConnectedObjectsFromFinded(AFigure); Result := nil; if Result = nil then begin Result := TObjectList.Create(false); 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[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end else for i := 0 to TConnectorObject(AFigure).JoinedConnectorsList.Count - 1 do begin JoinedConnObject := TConnectorObject(TConnectorObject(AFigure).JoinedConnectorsList[i]); for j := 0 to JoinedConnObject.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(JoinedConnObject.JoinedOrtholinesList[j]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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[i]); if FigureToResult is TOrtholine then if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end;} end else begin for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList[i]); if JoinedLine <> TOrthoLine(AFigure) then if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; 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[i]); if FigureToResult is TOrtholine then if FiguresInOrder.IndexOf(FigureToResult) = -1 then Result.Add(FigureToResult); end; {ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end;} end else begin for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList[i]); if JoinedLine <> TOrthoLine(AFigure) then if FiguresInOrder.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); end; end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList[i]); if FiguresInOrder.IndexOf(FigureToResult) = -1 then begin Result.Add(FigureToResult); end; end; end; end; //AddConnectedObjectsToFinded(AFigure, Result); end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TObjectList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure AddRelation(AConnectorObject: TConnectorObject); var RelationExists: Boolean; PointFigureRelation: TPointFigureRelation; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; CurrStepFigure: TFigure; i: Integer; begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AConnectorObject.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AConnectorObject.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали FirstTraceID := -1; LastTraceID := -1; if (PointFigureRelation.Traces.Count >= 2) and (CurrStepFigures.Count >= 2) then begin FirstTraceID := PointFigureRelation.Traces[0]; LastTraceID := PointFigureRelation.Traces[PointFigureRelation.Traces.Count - 1]; if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); if IsTrunkFigure(FirstConnector) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if IsTrunkFigure(TConnectorObject(AConnectorObject)) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AConnectorObject.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; end; procedure Step(AFigure: TFigure; AStepIndex: Integer); var ConnectedObjects: TList; //TObjectList; //ConnectedObject: TFigure; //PointFigureRelation: TPointFigureRelation; //RelationExists: Boolean; //CurrStepFigure: TFigure; //CheckedAsReverse: Boolean; //FirstTraceID: Integer; //LastTraceID: Integer; //LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and (AFigure <> FirstConnector) then begin AddRelation(TConnectorObject(AFigure)); { //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AFigure.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AFigure.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; if RelationExists then begin //*** учет разных линий, подключенных к магистрали FirstTraceID := -1; LastTraceID := -1; if (PointFigureRelation.Traces.Count >= 2) and (CurrStepFigures.Count >= 2) then begin FirstTraceID := PointFigureRelation.Traces[0]; LastTraceID := PointFigureRelation.Traces[PointFigureRelation.Traces.Count - 1]; if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); if IsTrunkFigure(FirstConnector) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if IsTrunkFigure(TConnectorObject(AFigure)) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; //Break; //// BREAK //// end; if RelationExists then Break; //// BREAK //// end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AFigure.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; } end; //else begin //CurrStepFigures.Add(AFigure); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin // Эта проверка создавала небольшие тормоза, теперь это делается в GetConnectedObjects {i := 0; while i <= ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); if FiguresInOrder.IndexOf(ConnectedObject) <> -1 then ConnectedObjects.Delete(i) else Inc(i); end;} if ConnectedObjects.Count > 0 then begin CurrStepFigures.Add(AFigure); for i := 0 to ConnectedObjects.Count - 1 do FiguresInOrder.Add(ConnectedObjects[i]); //FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //*** for i := 0 to ConnectedObjects.Count - 1 do begin //ConnectedObject := TFigure(ConnectedObjects[i]); //Step(ConnectedObject, AStepIndex+1); Step(TFigure(ConnectedObjects[i]), AStepIndex+1); end; //*** <Тело рекурсии/> for i := 0 to ConnectedObjects.Count - 1 do FiguresInOrder.Delete(FiguresInOrder.Count - 1); //FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; FreeAndNil(ConnectedObjects); //CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; begin Result := nil; PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFigures := TObjectList.Create(false); CurrStepFigures := TObjectList.Create(false); FiguresInOrder := TObjectList.Create(false); FiguresWithFindedConnections := TObjectList.Create(false); ListOfListConnectedObjects := TObjectList.Create(true); for i := 0 to List.PCad.FigureCount - 1 do begin CurrFigure := TFigure(List.PCad.Figures[i]); if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; FiguresInOrder.Clear; FiguresInOrder.Add(FirstConnector); Step(FirstConnector, 0); end; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); FreeAndNil(FiguresInOrder); FreeAndNil(PointFigures); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; end; *) { function GetPointObjectRelationsBetweenList(AIDList: Integer): TObjectList; var List: TF_CAD; PointFigureRelations: TObjectList; PointFigures: TObjectList; CurrFigure: TFigure; CurrStepFigures: TObjectList; FiguresInOrder: TObjectList; FirstConnector: TConnectorObject; FiguresWithFindedConnections: TObjectList; ListOfListConnectedObjects: TObjectList; TotalTick: Cardinal; OldTick: Cardinal; GetCount: Integer; i: Integer; procedure AddConnectedObjectsToFinded(AFigure: TFigure; AConnectedFigures: TObjectList); var ConnectedFigures: TObjectList; begin ConnectedFigures := TObjectList.Create(false); ConnectedFigures.Assign(AConnectedFigures); FiguresWithFindedConnections.Add(AFigure); ListOfListConnectedObjects.Add(ConnectedFigures); end; function GetConnectedObjectsFromFinded(AFigure: TFigure): TObjectList; var IndexFigure: Integer; ConnectedFigures: TObjectList; begin Result := nil; IndexFigure := FiguresWithFindedConnections.IndexOf(AFigure); if IndexFigure <> -1 then begin Result := TObjectList.Create(false); ConnectedFigures := TObjectList(ListOfListConnectedObjects[IndexFigure]); Result.Assign(ConnectedFigures); end; end; function GetConnectedObjects(AFigure: TFigure): TObjectList; var i, j: Integer; JoinedConnObject: TConnectorObject; ConnObject: TConnectorObject; ConnRaiseType: TConnRaiseType; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; begin Result := GetConnectedObjectsFromFinded(AFigure); if Result = nil then begin Result := TObjectList.Create(false); if AFigure is TConnectorObject then begin if TConnectorObject(AFigure).ConnectorType = ct_Clear then begin for i := 0 to TConnectorObject(AFigure).JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(TConnectorObject(AFigure).JoinedOrtholinesList[i])); end else for i := 0 to TConnectorObject(AFigure).JoinedConnectorsList.Count - 1 do begin JoinedConnObject := TConnectorObject(TConnectorObject(AFigure).JoinedConnectorsList[i]); for j := 0 to JoinedConnObject.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(JoinedConnObject.JoinedOrtholinesList[j])); 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 ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i])); end; end else begin for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList[i]); if JoinedLine <> TOrthoLine(AFigure) then Result.Add(JoinedLine); end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do Result.Add(TConnectorObject(ConnObject.JoinedConnectorsList[i])); end; // Сторона 2 ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector2); ConnRaiseType := ConnObject.FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then begin ListOfPassage := GetListOfPassage(ConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ConnObject.FID_ConnToPassage)); for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i])); end; end else begin for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList[i]); if JoinedLine <> TOrthoLine(AFigure) then Result.Add(JoinedLine); end; for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do Result.Add(TConnectorObject(ConnObject.JoinedConnectorsList[i])); end; end; AddConnectedObjectsToFinded(AFigure, Result); end; end; function IsTrunkFigure(AConnector: TConnectorObject): Boolean; begin Result := false; if (AConnector.FTrunkName = ctsnCrossATS) or (AConnector.FTrunkName = ctsnDistributionCabinet) then Result := true; end; function GetFirstLastLineFigureFromList(AList: TObjectList; AAsFirst: Boolean): TFigure; var i: Integer; CurrFigure: TFigure; begin Result := nil; if AAsFirst then begin for i := 0 to AList.Count - 1 do begin CurrFigure := TFigure(AList[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end else begin for i := AList.Count-1 downto 0 do begin CurrFigure := TFigure(AList[i]); if CurrFigure is TOrthoLine then begin Result := CurrFigure; Break; //// BREAK //// end; end; end; end; procedure Step(AFigure: TFigure); var ConnectedObjects: TList; //TObjectList; ConnectedObject: TFigure; PointFigureRelation: TPointFigureRelation; RelationExists: Boolean; CurrStepFigure: TFigure; CheckedAsReverse: Boolean; FirstTraceID: Integer; LastTraceID: Integer; LineFigure: TFigure; i: Integer; begin if (AFigure is TConnectorObject) and (AFigure <> FirstConnector) then begin //*** проверить нет ли уже точ-х объектов в списке RelationExists := false; for i := 0 to PointFigureRelations.Count - 1 do begin PointFigureRelation := TPointFigureRelation(PointFigureRelations[i]); CheckedAsReverse := false; if ((PointFigureRelation.FirstPointFigure = FirstConnector.ID) and (PointFigureRelation.LastPointFigure = AFigure.ID)) then RelationExists := true; if ((PointFigureRelation.LastPointFigure = FirstConnector.ID) and (PointFigureRelation.FirstPointFigure = AFigure.ID)) then begin RelationExists := true; CheckedAsReverse := true; end; begin //*** учет разных линий, подключенных к магистрали FirstTraceID := -1; LastTraceID := -1; if (PointFigureRelation.Traces.Count >= 2) and (CurrStepFigures.Count >= 2) then begin FirstTraceID := PointFigureRelation.Traces[0]; LastTraceID := PointFigureRelation.Traces[PointFigureRelation.Traces.Count - 1]; if CheckedAsReverse then ExchangeIntegers(FirstTraceID, LastTraceID); if IsTrunkFigure(FirstConnector) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, true); if (LineFigure <> nil) and (LineFigure.ID <> FirstTraceID) then RelationExists := false; end; if RelationExists then if IsTrunkFigure(TConnectorObject(AFigure)) then begin LineFigure := GetFirstLastLineFigureFromList(CurrStepFigures, false); if (LineFigure <> nil) and (LineFigure.ID <> LastTraceID) then RelationExists := false; end; end; if RelationExists then Break; //// BREAK //// //Break; //// BREAK //// end; end; if Not RelationExists then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstConnector.ID; PointFigureRelation.LastPointFigure := AFigure.ID; for i := 0 to CurrStepFigures.Count - 1 do begin CurrStepFigure := TFigure(CurrStepFigures[i]); if CurrStepFigure is TOrthoLine then PointFigureRelation.Traces.Add(CurrStepFigure.ID); end; PointFigureRelations.Add(PointFigureRelation); end; end; //else begin //CurrStepFigures.Add(AFigure); //OldTick := GetTickCount; ConnectedObjects := GetConnectedObjects(AFigure); //TotalTick := TotalTick + (GetTickCount - OldTick); //Inc(GetCount); if ConnectedObjects.Count > 0 then begin i := 0; while i <= ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); if FiguresInOrder.IndexOf(ConnectedObject) <> -1 then ConnectedObjects.Delete(i) else Inc(i); end; if ConnectedObjects.Count > 0 then begin CurrStepFigures.Add(AFigure); for i := 0 to ConnectedObjects.Count - 1 do FiguresInOrder.Insert(0, ConnectedObjects[i]); //FiguresInOrder.Add(ConnectedObjects[i]); //*** for i := 0 to ConnectedObjects.Count - 1 do begin ConnectedObject := TFigure(ConnectedObjects[i]); Step(ConnectedObject); end; //*** <Тело рекурсии/> for i := 0 to ConnectedObjects.Count - 1 do FiguresInOrder.Delete(0); //FiguresInOrder.Delete(FiguresInOrder.Count - 1); CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; FreeAndNil(ConnectedObjects); //CurrStepFigures.Delete(CurrStepFigures.Count - 1); end; end; begin Result := nil; PointFigureRelations := TObjectList.Create(true); Result := PointFigureRelations; TotalTick := 0; GetCount := 0; List := GetListByID(AIDList); if List <> nil then begin PointFigures := TObjectList.Create(false); CurrStepFigures := TObjectList.Create(false); FiguresInOrder := TObjectList.Create(false); FiguresWithFindedConnections := TObjectList.Create(false); ListOfListConnectedObjects := TObjectList.Create(true); for i := 0 to List.PCad.FigureCount - 1 do begin CurrFigure := TFigure(List.PCad.Figures[i]); if CurrFigure is TConnectorObject then if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then PointFigures.Add(CurrFigure); end; for i := 0 to PointFigures.Count - 1 do begin FirstConnector := TConnectorObject(PointFigures[i]); CurrStepFigures.Clear; FiguresInOrder.Clear; FiguresInOrder.Add(FirstConnector); Step(FirstConnector); end; FreeAndNil(ListOfListConnectedObjects); FreeAndNil(FiguresWithFindedConnections); FreeAndNil(CurrStepFigures); FreeAndNil(FiguresInOrder); FreeAndNil(PointFigures); end; //TotalTick := TotalTick + 1; Result := PointFigureRelations; end; } procedure UndoListInPM(aListID: Integer; aBasePath: string; AIsProject: Boolean; AListItemIndex, AListCount: Integer); var Catalog: TSCSCatalogExtended; CatalogNode: TTreeNode; NextSiblingNode: TTreeNode; CurrNode: TTreeNode; CurrParentNode: TTreeNode; ListIDs: TIntList; ListItemTypes: TIntList; CurrID: Integer; CurrItemType: Integer; SelectedID: Integer; SelectedItemType: Integer; NodeToSelect: TTreeNode; IDCurrList: Integer; i: Integer; SCSProject: TSCSProject; SCSList: TSCSList; IsLoadedData: Boolean; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // ChangedEvent: TTVChangedEvent;// Tolik 10/10/2022 -- begin // Tolik 14/06/2018 -- ListIDs := nil; ListItemTypes := nil; // //Exit; ///// EXIT ///// if DirectoryExists(aBasePath) then begin OldTick := GetTickCount; Catalog := nil; CatalogNode := nil; IsLoadedData := false; if AIsProject then begin Catalog := F_ProjMan.GSCSBase.CurrProject; SCSProject := F_ProjMan.GSCSBase.CurrProject; if Catalog.TreeViewNode = nil then Catalog.TreeViewNode := F_ProjMan.FindComponOrDirInTree(Catalog.ID, false); CatalogNode := Catalog.TreeViewNode; IDCurrList := 0; if SCSProject.CurrList <> nil then IDCurrList := SCSProject.CurrList.CurrID; if SCSProject.ComplexLoadFromDir(aBasePath) = ocrSuccessful then begin IsLoadedData := true; if IDCurrList <> 0 then SCSProject.CurrList := SCSProject.GetListBySCSID(IDCurrList); end; end else begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(aListID); if SCSList <> nil then begin if AListCount <= 1 then Catalog := SCSList else //*** Если задействовано несколько листов, и это последний, то обновляем в дереве проект if AListItemIndex = (AListCount-1) then Catalog := F_ProjMan.GSCSBase.CurrProject; if Catalog <> nil then begin CatalogNode := Catalog.TreeViewNode; if Catalog.TreeViewNode = nil then Catalog.TreeViewNode := F_ProjMan.FindComponOrDirInTree(Catalog.ID, false); end; if SCSList.ComplexLoadFromDir(aBasePath, false) = ocrSuccessful then begin IsLoadedData := true; SCSList.ProjectOwner := F_ProjMan.GSCSBase.CurrProject; //*** Вернуть подключения компонент F_ProjMan.GSCSBase.CurrProject.ConnectedComponsList.Clear; F_ProjMan.GSCSBase.CurrProject.ConnectedComponsList.Assign(SCSList.ConnectedComponsList); SCSList.ConnectedComponsList.Clear; // Вернуть блобы объектов F_ProjMan.GSCSBase.CurrProject.ObjectsBlobs.Clear; F_ProjMan.GSCSBase.CurrProject.ObjectsBlobs.Assign(SCSList.ObjectsBlobs); SCSList.ObjectsBlobs.Clear; //*** Обновить наименования свойств //*** Обновить связи, если последний лист if AListItemIndex = (AListCount - 1) then begin F_ProjMan.GSCSBase.CurrProject.SetComponentsJoining; F_ProjMan.GSCSBase.CurrProject.SetComponInterfacesForComlects; end; end; end; end; //*** перегрузить дерево if IsLoadedData and (Catalog <> nil) and (CatalogNode <> nil) then begin Catalog.TreeViewNode := CatalogNode; F_ProjMan.LockTreeAndGrid(true); F_ProjMan.Tree_Catalog.Items.BeginUpdate; // Tolik 21/09/2022 -- try ListIDs := TIntList.Create; ListItemTypes := TIntList.Create; //*** Определить видимые ветви NextSiblingNode := CatalogNode.getNextSibling; CurrNode := CatalogNode.getFirstChild; while CurrNode <> nil do begin ListIDs.Add(PObjectData(CurrNode.Data).ObjectID); ListItemTypes.Add(PObjectData(CurrNode.Data).ItemType); CurrNode := CurrNode.GetNextVisible; if CurrNode <> nil then if (CurrNode = NextSiblingNode) or (CurrNode.Level <= CatalogNode.Level) then Break; //// BREAK //// end; //*** Определить видимую ветвь SelectedID := -1; SelectedItemType := -1; if F_ProjMan.Tree_Catalog.Selected <> nil then begin SelectedID := PObjectData(F_ProjMan.Tree_Catalog.Selected.Data).ObjectID; SelectedItemType := PObjectData(F_ProjMan.Tree_Catalog.Selected.Data).ItemType; end; //*** Очистить подпапки DeleteChildNodes(CatalogNode); F_ProjMan.GSCSBase.CurrProject.SetItemsFTreeNodeToNil; CatalogNode.Text := Catalog.GetNameForVisible(true); CatalogNode.Expanded := true; //*** Видимые папки //Tolik 03/10/2022 -- закомментировал этот кусок, потому что он сильно тормозит { NodeToSelect := nil; for i := 0 to ListIDs.Count - 1 do begin CurrID := ListIDs[i]; CurrItemType := ListItemTypes[i]; CurrNode := nil; if IsCatalogItemType(CurrItemType) then CurrNode := F_ProjMan.FindComponOrDirInTree(CurrID, false) else CurrNode := F_ProjMan.FindComponOrDirInTree(CurrID, true); if CurrNode <> nil then begin CurrParentNode := CurrNode.Parent; while (Not CurrNode.IsVisible) and (CurrParentNode <> nil) do begin CurrParentNode.Expanded := true; CurrParentNode := CurrParentNode.Parent; end; if (SelectedID = CurrID) and (SelectedItemType = CurrItemType) then NodeToSelect := CurrNode; end; end; if NodeToSelect = nil then } NodeToSelect := CatalogNode; F_ProjMan.SelectNodeDirect(NodeToSelect); // Tolik 03/10/2022 -- NodeToSelect.Expand(false); if NodeToSelect <> nil then begin if Catalog.TreeViewNode = nil then Catalog.TreeViewNode := F_ProjMan.FindComponOrDirInTree(Catalog.ID, false); if Catalog.TreeViewNode <> nil then begin F_ProjMan.DefineCatalogNodeChildNodeExists(Catalog.TreeViewNode, Catalog.ItemsCount, Catalog.KolCompon); if Catalog.TreeViewNode.Count = 0 then F_ProjMan.AddNodes(Catalog.TreeViewNode); end; ShowNode(F_ProjMan.Tree_Catalog, NodeToSelect); F_ProjMan.Tree_Catalog.Selected := NodeToSelect; end; finally F_ProjMan.LockTreeAndGrid(false); F_ProjMan.Tree_Catalog.Items.EndUpdate; // Tolik 21/09/2022 -- NodeToSelect.Expand(false); NodeToSelect.MakeVisible; //F_ProjMan.Tree_Catalog.OnChange:= ChangedEvent; // Tolik 10/10/2022 -- end; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; // Tolik 14/06/2018 -- if ListIDs <> nil then ListIDs.Free; if ListItemTypes <> nil then ListItemTypes.Free; // end; procedure DeleteUndoFromPM(aListID: Integer; aBasePath: string; AIsProject: Boolean); begin if DirectoryExists(aBasePath) then FullRemoveDir(aBasePath, true, true); end; function SavePMForUndo(aID: Integer; AIsProject: Boolean; a3D: Boolean = false): String; begin Result := ''; if AIsProject then Result := SaveCurrProjectToUndoFiles else //Tolik 18/07/2025 -- //Result := SaveListToUndoFiles(AID); Result := SaveListToUndoFiles(AID, a3d); // end; //Tolik 11/07/2025 -- function SaveCurrProjectToUndoFiles(aFor3D: Boolean = false): String; begin Result := GetPathToSCSUndoUniqDir(aFor3D); if Not F_ProjMan.GSCSBase.CurrProject.ComplexSaveToDir(Result) then Result := ''; end; { function SaveCurrProjectToUndoFiles: String; begin Result := GetPathToSCSUndoUniqDir; if Not F_ProjMan.GSCSBase.CurrProject.ComplexSaveToDir(Result) then Result := ''; end; } function SaveListToUndoFiles(AListID: Integer; a3d: Boolean = false): String; var SCSList: TSCSList; begin Result := ''; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin Result := GetPathToSCSUndoUniqDir(a3D); //Tolik18/7/2025 -- if a3d then //тут практически будет 2 новых каталога, потому не создаст...нужно создать один, а второй (3Д) //уже создастся далее begin if Not DirectoryExists(Result) then CreateDir(Result); if DirectoryExists(Result) then Result := Result + '\' + GetUniqueFileName('', '') else Result := ''; end; // if Result = '' then exit; if Not SCSList.ComplexSaveToDir(Result) then Result := ''; end; end; function SaveCurrProjectToUndoStack: String; var i: Integer; ListIDs: TIntList; begin ListIDs := TIntList.Create; for i := 0 to F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 do ListIDs.Add(F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].CurrID); SaveForUndoFromPM(ListIDs, true); FreeAndNil(ListIDs); end; function SaveListToUndoStack(AListID: Integer): String; var ListIDs: TIntList; begin ListIDs := TIntList.Create; ListIDs.Add(AListID); SaveForUndoFromPM(ListIDs, false); FreeAndNil(ListIDs); end; procedure SaveListsToUndoStack(AListIDs: TIntList); begin SaveForUndoFromPM(AListIDs, false); end; function GetUserNameFromPM: String; begin Result := ''; if F_ProjMan <> nil then if F_ProjMan.FCurrUserInfo <> nil then begin if Not F_ProjMan.DM.UsersInfoPM.IsDefAdminUser then Result := ' - '+F_ProjMan.FCurrUserInfo.Name; end; end; function GetUserRightCaption(ARights: Integer): String; begin Result := ''; case ARights of rwrRead: Result := cNameRightReadB; rwrReadWrite: Result := cNameRightReadWriteB; rwrAdmin: Result := cNameRightAdminB; end; end; procedure LoginUserToProMan; begin if F_ProjMan <> nil then F_ProjMan.LoginUserToPM(false, false); end; procedure ShowPMUsers; var ReservUsers: TStringList; begin if F_ProjMan <> nil then if F_ProjMan.CheckAdminPM(true) then begin ReservUsers := TStringList.Create; try ReservUsers.Add(unAdmin); ReservUsers.Add(F_ProjMan.FCurrUserInfo.Name); if ShowUsers(F_ProjMan.DM.UsersInfoPM, true, F_ProjMan.FCurrUserInfo.Name, cSCSComponent_Msg17, ReservUsers) then begin F_ProjMan.DM.SaveUsersInfoPMToBase; // Внести измененный пароль в объект if F_ProjMan.DM.UsersInfoPM.LoggedUserInfo <> nil then F_ProjMan.FCurrUserInfo.Pass := F_ProjMan.DM.UsersInfoPM.LoggedUserInfo.Pass; end; finally FreeAndNil(ReservUsers); end; end; end; procedure ShowCurrUserInfo; var // StrToShow: String; ProjID: Integer; begin ProjID := 0; if F_ProjMan.GSCSBase.CurrProject.Active then ProjID := F_ProjMan.GSCSBase.CurrProject.CurrID; ShowFMainUserInfo(F_ProjMan, ProjID); {StrToShow := ''; if F_ProjMan <> nil then if F_ProjMan.FCurrUserInfo <> nil then begin StrToShow := cBaseCommon46_1+': '+F_ProjMan.FCurrUserInfo.Name+#10#13+ cBaseCommon46_2+': '+GetUserRightCaption(F_ProjMan.FCurrUserInfo.RightsPM)+#10#13+ cBaseCommon46_3+': '+GetUserRightCaption(F_ProjMan.FCurrUserInfo.RightsNB)+#10#13; if F_ProjMan.FProjUserInfo.ID <> 0 then begin StrToShow := StrToShow + #10#13+ cBaseCommon46_4+': '+F_ProjMan.FProjUserInfo.Name+#10#13+ cBaseCommon46_5+': '+GetUserRightCaption(F_ProjMan.FProjUserInfo.RightsPM)+#10#13; end; MessageModal(StrToShow, cBaseCommon46, MB_OK or MB_ICONINFORMATION); end;} end; function GetSelectedFieldValuesFromcxTable(AFieldName: String; ATableView: TcxGridDBTableView): TStringList; var i, j: Integer; ItemField: TcxCustomGridTableItem; begin Result := TStringList.Create; try ItemField := ATableView.DataController.GetItemByFieldName(AFieldName); if ItemField <> nil then for i := 0 to ATableView.Controller.SelectedRecordCount - 1 do if ItemField.Index <= (ATableView.Controller.SelectedRecords[i].ValueCount - 1) then Result.Add(ATableView.Controller.SelectedRecords[i].Values[ItemField.Index]); except on E: Exception do AddExceptionToLogEx('GetSelectedFieldValuessFromcxTable', E.Message); end; end; function GetSelectedIDsFromcxTable(ATableView: TcxGridDBTableView): TIntList; var SelectedFieldIDs: TStringList; i: Integer; CurrID: Integer; begin Result := TIntList.Create; SelectedFieldIDs := nil; // Tolik 14/06/2018 -- try SelectedFieldIDs := GetSelectedFieldValuesFromcxTable(fnID, ATableView); for i := 0 to SelectedFieldIDs.Count - 1 do begin CurrID := 0; try CurrID := StrToInt(SelectedFieldIDs[i]); except end; Result.Add(CurrID); end; except on E: Exception do AddExceptionToLogEx('GetSelectedIDsFromcxTable', E.Message); end; // Tolik 14/06/2018 - - if SelectedFieldIDs <> nil then SelectedFieldIDs.Free; // end; function CreateComponInPMByType(ATrgObject: TObject; const ACompTypeSysName: String; AIsLine: Integer): TObject; var NewSCSompon: TSCSComponent; SCSList: TSCSList; SCSProj: TSCSProject; NBComponentType: TNBComponentType; SprComponentType: TNBComponentType; TrgCompon: TSCSComponent; TrgObject: TSCSCatalog; TrgNode: TTreeNode; ComponKind: TComponKind;// (ckCompon, ckCompl, ckNone) begin Result := nil; try if (ATrgObject <> nil) then begin SCSProj := nil; SCSList := nil; TrgCompon := nil; TrgObject := nil; TrgNode := nil; ComponKind := ckNone; if ATrgObject is TSCSCatalog then begin SCSList := TSCSCatalog(ATrgObject).GetListOwner; //F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AIDList); TrgObject := TSCSCatalog(ATrgObject); F_ProjMan.FindComponOrDirInTree(TrgObject.ID, false); TrgNode := TSCSCatalog(ATrgObject).TreeViewNode; ComponKind := ckCompon; end else if ATrgObject is TSCSComponent then begin SCSList := TSCSComponent(ATrgObject).GetListOwner; TrgCompon := TSCSComponent(ATrgObject); TrgObject := TrgCompon.GetFirstParentCatalog; F_ProjMan.FindComponOrDirInTree(TrgCompon.ID, true); TrgNode := TrgCompon.TreeViewNode; ComponKind := ckCompl; end; if SCSList <> nil then begin SCSProj := SCSList.GetProject; SprComponentType := SCSProj.Spravochnik.GetComponentTypeObjBySysName(ACompTypeSysName); if SprComponentType = nil then begin NBComponentType := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ACompTypeSysName); if NBComponentType <> nil then SprComponentType := NBComponentType; end; if SprComponentType <> nil then begin if (TrgCompon <> nil) and (TrgCompon.TreeViewNode <> nil) then F_ProjMan.DefineChildNodes(TrgCompon.TreeViewNode); NewSCSompon := TSCSComponent.Create(F_ProjMan); NewSCSompon.Name := SprComponentType.ComponentType.Name; NewSCSompon.GUIDComponentType := SprComponentType.ComponentType.GUID; NewSCSompon.ComponentType := SprComponentType.ComponentType; NewSCSompon.IsLine := SprComponentType.ComponentType.IsLine; if AIsLine <> -1 then NewSCSompon.IsLine := AIsLine; NewSCSompon.ISComplect := biFalse; F_ProjMan.SaveComponent(NewSCSompon, TrgCompon, TrgNode, F_ProjMan, F_ProjMan, nil, TrgObject, true, true, ComponKind); F_ProjMan.AfterSaveComponent(0, NewSCSompon, TrgObject, F_ProjMan, F_ProjMan, ComponKind, mrNone, nil, false); NewSCSompon.LoadPropertyesFromComponentType; NewSCSompon.SaveProperties(NewSCSompon.ID); if ComponKind = ckCompl then TrgCompon.ComplectWith(NewSCSompon, -1, true, true); AddNewSprGUIDsToProjectFromComponent(NewSCSompon, NewSCSompon.ProjectOwner.Spravochnik); Result := NewSCSompon; end; end; end; except on E: Exception do AddExceptionToLogEx('CreateComponInPM', E.Message); end; end; function CreateHouseInPM(AListID: Integer): Integer; var SCSList: TSCSList; ObjectNode: TTreeNode; SCSObject: TSCSCatalog; HouseCompon: TSCSComponent; SprComponentType: TNBComponentType; begin Result := 0; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin SCSList.Spravochnik.CreateCompTypeByStandartGUID(ctsnHouse, guidCompTypeHouse); SprComponentType := SCSList.ProjectOwner.Spravochnik.CreateCompTypeByStandartGUID(ctsnHouse, guidCompTypeHouse); if SprComponentType <> nil then begin ObjectNode := F_ProjMan.MakeDir(cfCAD, SCSList.TreeViewNode, SprComponentType.ComponentType.Name, itSCSConnector, nil); if ObjectNode <> nil then begin SCSObject := SCSList.GetCatalogFromReferences(PObjectData(ObjectNode.Data).ObjectID); if SCSObject <> nil then begin HouseCompon := TSCSComponent.Create(F_ProjMan); HouseCompon.Name := SprComponentType.ComponentType.Name; HouseCompon.GUIDComponentType := SprComponentType.ComponentType.GUID; HouseCompon.ComponentType := SprComponentType.ComponentType; HouseCompon.IsLine := SprComponentType.ComponentType.IsLine; HouseCompon.ISComplect := biFalse; F_ProjMan.SaveComponent(HouseCompon, nil, ObjectNode, F_ProjMan, F_ProjMan, nil, SCSObject, true, true, ckCompon); F_ProjMan.AfterSaveComponent(0, HouseCompon, SCSObject, F_ProjMan, F_ProjMan, ckCompon, mrNone, nil, false); HouseCompon.LoadPropertyesFromComponentType; HouseCompon.SaveProperties(HouseCompon.ID); //Result := HouseCompon.ID; Result := SCSObject.SCSID; end; end; end; end; end; function CreateApproachInPM(AListID, AHouseID: Integer; var AApproachComponID: Integer): Integer; var SCSList: TSCSList; ObjectNode: TTreeNode; SCSObject: TSCSCatalog; HouseCompon: TSCSComponent; ApproachCompon: TSCSComponent; SprComponentType: TNBComponentType; begin Result := 0; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then begin SCSList.Spravochnik.CreateCompTypeByStandartGUID(ctsnApproach, guidCompTypeApproach); SprComponentType := SCSList.ProjectOwner.Spravochnik.CreateCompTypeByStandartGUID(ctsnApproach, guidCompTypeApproach); //HouseCompon := SCSList.GetComponentFromReferences(AHouseID); SCSObject := SCSList.GetCatalogFromReferencesBySCSID(AHouseID); HouseCompon := nil; if SCSObject <> nil then HouseCompon := SCSObject.GetFirstComponent; if (SprComponentType <> nil) and (HouseCompon <> nil) then begin //SCSObject := HouseCompon.GetFirstParentCatalog; ObjectNode := nil; if SCSObject <> nil then begin F_ProjMan.FindComponOrDirInTree(HouseCompon.ID, true); ObjectNode := SCSObject.TreeViewNode; ApproachCompon := TSCSComponent.Create(F_ProjMan); ApproachCompon.Name := SprComponentType.ComponentType.Name; ApproachCompon.GUIDComponentType := SprComponentType.ComponentType.GUID; ApproachCompon.ComponentType := SprComponentType.ComponentType; ApproachCompon.IsLine := SprComponentType.ComponentType.IsLine; ApproachCompon.ISComplect := biFalse; F_ProjMan.SaveComponent(ApproachCompon, HouseCompon, HouseCompon.TreeViewNode, F_ProjMan, F_ProjMan, nil, SCSObject, true, true, ckCompl); F_ProjMan.AfterSaveComponent(0, ApproachCompon, SCSObject, F_ProjMan, F_ProjMan, ckCompl, mrNone, nil, false); ApproachCompon.LoadPropertyesFromComponentType; ApproachCompon.SaveProperties(HouseCompon.ID); HouseCompon.ComplectWith(ApproachCompon, -1, true, true); //Result := ApproachCompon.ID; AApproachComponID := ApproachCompon.ID; Result := GenNewSCSID; end; end; end; end; procedure DeleteComponInPM(AListID, AComponID: Integer; ACompon: TObject=nil); var SCSList: TSCSList; Compon: TSCSComponent; begin Compon := TSCSComponent(ACompon); if Compon = nil then begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(AListID); if SCSList <> nil then Compon := SCSList.GetComponentFromReferences(AComponID); end; if Compon <> nil then F_ProjMan.DelCompon(Compon, Compon.TreeViewNode, true, true, true, true); end; procedure SelectComponInPM(AListID, AComponID: Integer); var ComponNode: TTreeNode; begin //F_ProjMan.SelectComponByIDInTree(AComponID); //if AListID > 0 then // ComponNode := F_ProjMan.FindComponOrDirInTreeByList(AListID, AComponID, true) //else ComponNode := F_ProjMan.FindComponOrDirInTree(AComponID, true); if ComponNode <> nil then F_ProjMan.SelectNodeDirect(ComponNode); end; function GetControlFromListByTag(AControls: TList; ATag: Integer): TControl; var i: Integer; begin Result := nil; for i := 0 to AControls.Count - 1 do begin if TControl(AControls[i]).Tag = ATag then begin Result := TControl(AControls[i]); Break; //// BREAK //// end; end; end; function GetControlScreenPt(aControl: TControl; aCorner: TAreaCornerType=ctTopLeft): TPoint; begin Result.X := aControl.Left; Result.Y := aControl.Top; case aCorner of ctTopMiddle: Result.X := Result.X + Round(aControl.Width/2); ctTopRight: Result.X := Result.X + aControl.Width; ctRightMiddle: begin Result.X := Result.X + aControl.Width; Result.Y := Result.Y + Round(aControl.Height/2); end; ctBottomRight: begin Result.X := Result.X + aControl.Width; Result.Y := Result.Y + aControl.Height; end; ctBottomMiddle: begin Result.X := Result.X + Round(aControl.Width/2); Result.Y := Result.Y + aControl.Height; end; ctBottomLeft: Result.Y := Result.Y + aControl.Height; ctLeftMiddle: Result.Y := Result.Y + Round(aControl.Height/2); ctMiddle: begin Result.X := Result.X + Round(aControl.Width/2); Result.Y := Result.Y + Round(aControl.Height/2); end; end; if aControl.Parent <> nil then Result := aControl.Parent.ClientToScreen(Result) else Result := aControl.ClientToScreen(Result); end; //Добавление количества портов и количество жил на порт procedure DefineImpotantProperty1; var MasIDTypeCompon, MasComponID: TIntList; TopNode: TTreeNode; index, i, j, operId, operKol, n: integer; operCompon: TSCSComponent; idProp_IdKolPort, idProp_IdKolJil: integer; operObject: TObject; operProperty: TSCSProperty; JilNet, PortovNet: boolean; KolPort, KolJil: integer; NBInterface1, NBInterface2: TNBInterface; InterfComponIsLine, AccordComponIsLine: integer; InterfAccordance: TRapList; IsAccordanceInterface: boolean; KolvoInterf1, KolvoInterf2: integer; NBInterfaceACcordance: TNBInterfaceACcordance; SaveOption: TpFIBQueryOptions; GlobalMasJil, GlobalMasPort: TIntList; str: string; begin operCompon := TSCSComponent.Create(F_NormBase); GlobalMasJil := TIntList.Create; GlobalMasPort := TIntList.Create; MasComponID := TIntList.Create; MasIDTypeCompon := TIntList.Create; try operObject := Nil; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnPortCount); idProp_IdKolPort := -1; idProp_IdKolJil := -1; if (assigned(operObject)) then begin idProp_IdKolPort := TNBProperty(operObject).PropertyData.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnPortWireCount); if (assigned(operObject)) then begin idProp_IdKolJil := TNBProperty(operObject).PropertyData.ID; operObject := Nil; end; //насипка ID-шников для типов компонентов MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnModule + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnOFConnector + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnSocket + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnCupboard + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnPatchPanel + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnOFModule + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnOFModule + ''''), laOr); {operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ctsnModule); if (assigned(operObject)) then begin MasIDTypeCompon.Add(TNBComponentType(operObject).ComponentType.ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ctsnOFConnector); if (assigned(operObject)) then begin MasIDTypeCompon.Add(TNBComponentType(operObject).ComponentType.ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ctsnSocket); if (assigned(operObject)) then begin MasIDTypeCompon.Add(TNBComponentType(operObject).ComponentType.ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ctsnCupboard); if (assigned(operObject)) then begin MasIDTypeCompon.Add(TNBComponentType(operObject).ComponentType.ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeObjBySysName(ctsnPatchPanel); if (assigned(operObject)) then begin MasIDTypeCompon.Add(TNBComponentType(operObject).ComponentType.ID); operObject := Nil; end; } //указываем айдишник интерфейса "1 pin" operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{4546EF81-C089-4CEA-9F6F-2DB31DF34DF3}'); if (Assigned(operObject)) then begin NBInterface1 := TNBInterface(operObject); operObject := Nil; end; F_NormBase.DM.Query_Select.Close; F_NormBase.DM.Query_Select.SQL.Clear; Str := 'Select id from component where ID_COMPONENT_TYPE in (' + IntToStr(MasIDTypeCompon[0]); for i := 1 to MasIDTypeCompon.Count - 1 do begin Str := Str + ', ' + IntToStr(MasIDTypeCompon[i]); end; // id_property = ' + IntToStr(idProp_IdKolJil) + Str := Str + ') and (id not in (select id_component from comp_prop_relation where id_property = ' + IntToStr(idProp_IdKolPort) + ')' + ' or id not in (select id_component from comp_prop_relation where id_property = ' + IntToStr(idProp_IdKolJil) + '))'; F_NormBase.DM.Query_Select.SQL.Text := Str; try F_NormBase.DM.Query_Select.ExecQuery; //F_NormBase.DM.Query_Select.; While not F_NormBase.DM.Query_Select.Eof do begin MasComponID.Add(F_NormBase.DM.Query_Select.Fields[0].AsInteger); F_NormBase.DM.Query_Select.Next; end; except end; //MasComponID := F_NormBase.DM.GetCatalogAllComponIDs(PObjectData(TopNode.Data).id); //начало цикла перебора вссех компонентов for index := 0 to MasComponID.Count - 1 do begin operCompon.ID := MasComponID[index]; operCompon.LoadComponentByID(operCompon.ID); operCompon.LoadInterfaces(-1, false); operCompon.LoadProperties; //в шкафы, розетки, модули добавим свойство количество портов и количество жил на порт JilNet := true; PortovNet := true; for i := 0 to operCompon.Properties.Count - 1 do begin if PProperty(operCompon.Properties[i]).ID_Property = idProp_IdKolPort then PortovNet := false; if PProperty(operCompon.Properties[i]).ID_Property = idProp_IdKolJil then JilNet := false; end; //if PortovNet then begin KolPort := 0; for i := 0 to operCompon.Interfaces.Count - 1 do begin if operCompon.Interfaces[i].IsPort = 1 then begin KolPort := KolPort + operCompon.Interfaces[i].Kolvo; end; end; end; if (KolPort > 0) and JilNet then begin if Assigned(NBInterface1) then begin KolJil := 0; for n := 0 to operCompon.Interfaces.Count - 1 do begin if (operCompon.Interfaces[n].IsPort = 0) and (operCompon.Interfaces[n].TypeI = 0) then begin operId := F_NormBase.DM.GetIntFromTable(tnPortInterfaceRelation, fnIDPort, fnIDInterfRel, operCompon.Interfaces[n].ID, qmPhisical); if operId > -1 then begin for j := 0 to operCompon.Interfaces.Count - 1 do begin if operCompon.Interfaces[j].ID = operId then begin operKol := operCompon.Interfaces[j].Kolvo; break; end; end; end else begin operKol := 1; end; if operCompon.Interfaces[n].ID_Interface <> NBInterface1.ID then begin operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByID(operCompon.Interfaces[n].ID_Interface); if (Assigned(operObject)) then begin NBInterface2 := TNBInterface(operObject); operObject := Nil; end; //вставка, которая определяет количество жил в функциональном интерфейсе if (NBInterface1 <> nil) or (NBInterface2 <> nil) then begin InterfAccordance := TRapList.Create; try // if NBInterface1 <> nil then // for i := 0 to NBInterface1.InterfaceAccordance.Count - 1 do // InterfAccordance.Add(NBInterface1.InterfaceAccordance.List.List^[i]); if NBInterface2 <> nil then for i := 0 to NBInterface2.InterfaceAccordance.Count - 1 do InterfAccordance.Add(NBInterface2.InterfaceAccordance.List.List^[i]); for i := 0 to InterfAccordance.Count - 1 do begin KolvoInterf2 := 0; NBInterfaceACcordance := TNBInterfaceACcordance(InterfAccordance[i]); //GUIDInterface := NBInterfaceACcordance.GuidInterface; //GUIDAccordance := NBInterfaceACcordance.GUIDAccordance; InterfComponIsLine := NBInterfaceACcordance.InterfComponIsLine; AccordComponIsLine := NBInterfaceACcordance.AccordComponIsLine; IsAccordanceInterface := false; if (NBInterface1.GUID = NBInterfaceACcordance.GuidInterface) and (NBInterface2.GUID = NBInterfaceACcordance.GUIDAccordance) and (InterfComponIsLine = ltAnyType) and (AccordComponIsLine = ltAnyType) then begin IsAccordanceInterface := true; KolvoInterf1 := 1; KolvoInterf2 := NBInterfaceACcordance.Kolvo; end else if (NBInterface1.GUID = NBInterfaceACcordance.GUIDAccordance) and (NBInterface2.GUID = NBInterfaceACcordance.GuidInterface) and (AccordComponIsLine = ltAnyType) and (InterfComponIsLine = ltAnyType) then begin IsAccordanceInterface := true; KolvoInterf1 := NBInterfaceACcordance.Kolvo; KolvoInterf2 := 1; end; if IsAccordanceInterface then begin Break; ///// BREAK ///// end; end; finally InterfAccordance.Free; end; end; //конец вставки для поиска количества жил KolJil := KolJil + operCompon.Interfaces[n].Kolvo * operKol * KolvoInterf1; end else begin KolJil := KolJil + operCompon.Interfaces[n].Kolvo * operKol; end; // KolPort := KolPort + operCompon.Interfaces[i].Kolvo; end; end; end else begin KolJil := 1; end; //поправка на всякий потусторонний случай {if KolPort = 0 then begin KolPort := 1; end; if KolJil = 0 then begin //KolJil := 1; end else } if (KolJil > 0) and (KolPort > 0) then begin //считаем количество жил на порт KolJil := ceil (KolJil/KolPort); //if KolJil = 0 then KolJil := 1; end; end; //наполняем глобальные массивы if PortovNet and (KolPort > 0) then begin GlobalMasPort.Add(KolPort); end else begin GlobalMasPort.Add(-1); end; //наполняем глобальные массивы if JilNet and (KolJil > 0) then begin GlobalMasJil.Add(KolJil); end else begin GlobalMasJil.Add(-1); end; end; //конец цикла перебора компонентов //добавление необходимых свойств компонентам F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'insert into comp_prop_relation (id_component, id_property, pvalue, guid) values (:par1, :par2, :par3, :par4)'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to MasComponID.Count - 1 do begin if GlobalMasPort[index] > -1 then begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := idProp_IdKolPort; F_NormBase.DM.Query_Operat.Params[2].AsInteger := GlobalMasPort[index]; F_NormBase.DM.Query_Operat.Params[3].AsString := CreateGUID; F_NormBase.DM.Query_Operat.ExecQuery; end; if GlobalMasJil[index] > -1 then begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := idProp_IdKolJil; F_NormBase.DM.Query_Operat.Params[2].AsInteger := GlobalMasJil[index]; F_NormBase.DM.Query_Operat.Params[3].AsString := CreateGUID; F_NormBase.DM.Query_Operat.ExecQuery; end; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Close; F_NormBase.DM.Query_Operat.Options := SaveOption; end; finally operCompon.Free; GlobalMasJil.Free; GlobalMasPort.Free; MasComponID.Free; MasIDTypeCompon.Free; end; end; //добавление количества жил на кабель procedure DefineImpotantProperty2; var i, n, index, j : integer; idProp_IdKolJil, KolJil: integer; operCompon: TSCSComponent; MasComponID, MasIDTypeCompon: TIntList; GlobalMasJil: TIntList; operObject: TObject; str: string; JilNet, IsAccordanceInterface: boolean; NBInterface1, NBInterface2: TNBInterface; InterfAccordance: TRapList; NBInterfaceACcordance: TNBInterfaceACcordance; KolvoInterf2, KolvoInterf1: integer; InterfComponIsLine, AccordComponIsLine : integer; SaveOption: TpFIBQueryOptions; begin operCompon := TSCSComponent.Create(F_NormBase); MasIDTypeCompon := TIntList.Create; GlobalMasJil := TIntList.Create; MasComponID := TIntList.Create; try MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnCable + ''''), laOr); MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnOFCable + ''''), laOr); operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{4546EF81-C089-4CEA-9F6F-2DB31DF34DF3}'); if (Assigned(operObject)) then begin NBInterface1 := TNBInterface(operObject); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnWireCount); if (assigned(operObject)) then begin idProp_IdKolJil := TNBProperty(operObject).PropertyData.ID; operObject := Nil; end; F_NormBase.DM.Query_Select.Close; F_NormBase.DM.Query_Select.SQL.Clear; Str := 'Select id from component where ID_COMPONENT_TYPE in (' + IntToStr(MasIDTypeCompon[0]); for i := 1 to MasIDTypeCompon.Count - 1 do begin Str := Str + ', ' + IntToStr(MasIDTypeCompon[i]); end; // id_property = ' + IntToStr(idProp_IdKolJil) + Str := Str + ') and id not in (select id_component from comp_prop_relation where id_property = ' + IntToStr(idProp_IdKolJil) + ')'; F_NormBase.DM.Query_Select.SQL.Text := Str; try F_NormBase.DM.Query_Select.ExecQuery; //F_NormBase.DM.Query_Select.; While not F_NormBase.DM.Query_Select.Eof do begin MasComponID.Add(F_NormBase.DM.Query_Select.Fields[0].AsInteger); F_NormBase.DM.Query_Select.Next; end; except end; for index := 0 to MasComponID.Count - 1 do begin operCompon.ID := MasComponID[index]; operCompon.LoadComponentByID(operCompon.ID); operCompon.LoadInterfaces(-1, false); operCompon.LoadProperties; JilNet := true; for i := 0 to operCompon.Properties.Count - 1 do begin if PProperty(operCompon.Properties[i]).ID_Property = idProp_IdKolJil then JilNet := false; end; if JilNet then begin if Assigned(NBInterface1) then begin KolJil := 0; for n := 0 to operCompon.Interfaces.Count - 1 do begin if operCompon.Interfaces[n].TypeI = 0 then begin if operCompon.Interfaces[n].ID_Interface <> NBInterface1.ID then begin operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByID(operCompon.Interfaces[n].ID_Interface); if (Assigned(operObject)) then begin NBInterface2 := TNBInterface(operObject); operObject := Nil; end; //вставка, которая определяет количество жил в функциональном интерфейсе if (NBInterface1 <> nil) or (NBInterface2 <> nil) then begin KolvoInterf2 := 1; KolvoInterf1 := 1; InterfAccordance := TRapList.Create; try // if NBInterface1 <> nil then // for i := 0 to NBInterface1.InterfaceAccordance.Count - 1 do // InterfAccordance.Add(NBInterface1.InterfaceAccordance.List.List^[i]); if NBInterface2 <> nil then for i := 0 to NBInterface2.InterfaceAccordance.Count - 1 do InterfAccordance.Add(NBInterface2.InterfaceAccordance.List.List^[i]); for i := 0 to InterfAccordance.Count - 1 do begin KolvoInterf2 := 1; KolvoInterf1 := 1; NBInterfaceACcordance := TNBInterfaceACcordance(InterfAccordance[i]); //GUIDInterface := NBInterfaceACcordance.GuidInterface; //GUIDAccordance := NBInterfaceACcordance.GUIDAccordance; InterfComponIsLine := NBInterfaceACcordance.InterfComponIsLine; AccordComponIsLine := NBInterfaceACcordance.AccordComponIsLine; IsAccordanceInterface := false; if (NBInterface1.GUID = NBInterfaceACcordance.GuidInterface) and (NBInterface2.GUID = NBInterfaceACcordance.GUIDAccordance) and (InterfComponIsLine = ltAnyType) and (AccordComponIsLine = ltAnyType) then begin IsAccordanceInterface := true; KolvoInterf1 := 1; KolvoInterf2 := NBInterfaceACcordance.Kolvo; end else if (NBInterface1.GUID = NBInterfaceACcordance.GUIDAccordance) and (NBInterface2.GUID = NBInterfaceACcordance.GuidInterface) and (AccordComponIsLine = ltAnyType) and (InterfComponIsLine = ltAnyType) then begin IsAccordanceInterface := true; KolvoInterf1 := NBInterfaceACcordance.Kolvo; KolvoInterf2 := 1; end; if IsAccordanceInterface then begin Break; ///// BREAK ///// end; end; if not IsAccordanceInterface then begin KolvoInterf1 := 1; end; finally InterfAccordance.Free; end; end; //конец вставки для поиска количества жил KolJil := KolJil + operCompon.Interfaces[n].Kolvo * KolvoInterf1 end else begin KolJil := KolJil + operCompon.Interfaces[n].Kolvo; end; end; end; end else begin KolJil := 0; for n := 0 to operCompon.Interfaces.Count - 1 do begin if operCompon.Interfaces[n].TypeI = 0 then begin KolJil := KolJil + operCompon.Interfaces[n].Kolvo; end; end; KolJil := ceil(KolJil/2); end; if KolJil = 0 then begin KolJil := 1; end else begin //считаем количество жил на порт KolJil := ceil (KolJil/2); if KolJil = 0 then KolJil := 1; end; if JilNet then begin GlobalMasJil.Add(KolJil); end else begin GlobalMasJil.Add(-1); end; end; end; //конец цикла перебора компонентов //добавление необходимых свойств компонентам F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'insert into comp_prop_relation (id_component, id_property, pvalue, guid) values (:par1, :par2, :par3, :par4)'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to MasComponID.Count - 1 do begin if GlobalMasJil[index] > -1 then begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := idProp_IdKolJil; F_NormBase.DM.Query_Operat.Params[2].AsInteger := GlobalMasJil[index]; F_NormBase.DM.Query_Operat.Params[3].AsString := CreateGUID; F_NormBase.DM.Query_Operat.ExecQuery; end; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Close; F_NormBase.DM.Query_Operat.Options := SaveOption; end; finally operCompon.Free; GlobalMasJil.Free; MasIDTypeCompon.Free; MasComponID.Free; end; end; //добавление количества жил на кабель procedure DefineImpotantProperty3;///Макс var i, n, index, j : integer; NeedPropertyID: integer; operCompon: TSCSComponent; MasComponID, MasIDTypeCompon, MasNeedInterfases: TIntList; GlobalMas: TStringList; operObject: TObject; sidesection, str: string; SaveOption: TpFIBQueryOptions; begin operCompon := TSCSComponent.Create(F_NormBase); MasIDTypeCompon := TIntList.Create; MasNeedInterfases := TIntList.Create; GlobalMas := TStringList.Create; MasComponID := TIntList.Create; try MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnCableChannel + ''''), laOr); //интерфейсы сторон кабельного канала operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{5445A0DA-EDB6-478B-952B-B2017E911C3B}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{8DB526EE-AD5A-4B36-B31B-1CCA0432C2F9}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{F9A8B027-DC22-48AD-8DF1-BF50C9FE6E53}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{AAF3A516-D1CE-4198-8792-D90733EE9738}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnCableChannelSideSection); if (assigned(operObject)) then begin NeedPropertyID := TNBProperty(operObject).PropertyData.ID; operObject := Nil; end; F_NormBase.DM.Query_Select.Close; F_NormBase.DM.Query_Select.SQL.Clear; Str := 'Select id from component where ID_COMPONENT_TYPE in (' + IntToStr(MasIDTypeCompon[0]); for i := 1 to MasIDTypeCompon.Count - 1 do begin Str := Str + ', ' + IntToStr(MasIDTypeCompon[i]); end; // id_property = ' + IntToStr(idProp_IdKolJil) + Str := Str + ') and id not in (select id_component from comp_prop_relation where id_property = ' + IntToStr(NeedPropertyID) + ')'; F_NormBase.DM.Query_Select.SQL.Text := Str; try F_NormBase.DM.Query_Select.ExecQuery; //F_NormBase.DM.Query_Select.; While not F_NormBase.DM.Query_Select.Eof do begin MasComponID.Add(F_NormBase.DM.Query_Select.Fields[0].AsInteger); F_NormBase.DM.Query_Select.Next; end; except end; for index := 0 to MasComponID.Count - 1 do begin operCompon.ID := MasComponID[index]; operCompon.LoadComponentByID(operCompon.ID); operCompon.LoadInterfaces(-1, false); operCompon.LoadProperties; sidesection := ''; for i := 0 to operCompon.Interfaces.Count-1 do begin for j := 0 to MasNeedInterfases.Count-1 do begin if operCompon.Interfaces[i].ID_Interface = MasNeedInterfases[j] then begin sidesection := operCompon.Interfaces[i].SideSection; break; end; end; if sidesection <> '' then break; end; GlobalMas.Add(sidesection); end; //конец перебора компонентов //добавление необходимого свойства компонентам F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'insert into comp_prop_relation (id_component, id_property, pvalue, guid) values (:par1, :par2, :par3, :par4)'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to MasComponID.Count - 1 do begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := NeedPropertyID; F_NormBase.DM.Query_Operat.Params[2].AsString := GlobalMas[index]; F_NormBase.DM.Query_Operat.Params[3].AsString := CreateGUID; F_NormBase.DM.Query_Operat.ExecQuery; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Close; F_NormBase.DM.Query_Operat.Options := SaveOption; end; finally MasComponID.Free; MasNeedInterfases.Free; operCompon.Free; MasIDTypeCompon.Free; GlobalMas.Free; end; end; //добавление свойств на элементы каб канала procedure DefineImpotantProperty4;///Макс var i, n, index, j : integer; NeedPropertyID: integer; operCompon: TSCSComponent; MasComponID, MasIDTypeCompon, MasNeedInterfases: TIntList; GlobalMasIDCompon, GlobalMasIDProperty, GlobalMasTypeCompon: TIntList; GlobalMasValueProperty: TStringList; operObject: TObject; sidesection, str: string; SaveOption: TpFIBQueryOptions; IDElementOfCC, IDAdapter, IDUgol, IDUnion, IDVVod, IDBlank, IDTroynik, IDKRestovina: integer; IDPropSide1, IDPropSide2, IDPropSide3, IDPropSide4, IDPropSide, IDPropTypeElement: integer; TypeElement, Kolside: integer; begin operCompon := TSCSComponent.Create(F_NormBase); MasIDTypeCompon := TIntList.Create; MasNeedInterfases := TIntList.Create; GlobalMasValueProperty := TStringList.Create; GlobalMasIDCompon := TIntList.Create; GlobalMasIDProperty := TIntList.Create; GlobalMasTypeCompon := TIntList.Create; MasComponID := TIntList.Create; try //типы компонентов MasIDTypeCompon.Assign(F_NormBase.DM.GetComponentTypesFieldValuesAsInteger(fnId, 'sysname = '''+ ctsnCableChannelElement + ''''), laOr); //интерфейсы сторон кабельного канала operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{5445A0DA-EDB6-478B-952B-B2017E911C3B}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{8DB526EE-AD5A-4B36-B31B-1CCA0432C2F9}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{F9A8B027-DC22-48AD-8DF1-BF50C9FE6E53}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetInterfaceByGUID('{AAF3A516-D1CE-4198-8792-D90733EE9738}'); if (Assigned(operObject)) then begin MasNeedInterfases.add (TNBInterface(operObject).ID); operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnCableChannelSideSection); if (assigned(operObject)) then begin NeedPropertyID := TNBProperty(operObject).PropertyData.ID; operObject := Nil; end; //определяем айдишники типов комопнентов operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{DE9D24BE-1066-4E62-B92B-ED2ABF6FB2BF}'); if (assigned(operObject)) then begin IDElementOfCC := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{82FE2C3B-2B46-4B66-96C4-99F22448006A}'); if (assigned(operObject)) then begin IDAdapter := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{46367268-D388-4F92-AE80-E47284F4F4BE}'); if (assigned(operObject)) then begin IDBlank := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{533794A3-6E36-4ED0-A1DF-91F2819BDDA0}'); if (assigned(operObject)) then begin IDUnion := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{331A46EF-2E45-4519-88E7-314659663EAB}'); if (assigned(operObject)) then begin IDTroynik := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{9F3FE58A-6D26-4630-9776-838874196A52}'); if (assigned(operObject)) then begin IDUgol := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{E7FC6A24-ECF8-4762-953A-54B90AA73F33}'); if (assigned(operObject)) then begin IDVVod := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetComponentTypeByGUID('{A16F3593-6FBF-4803-8FE5-A62C424C7C6D}'); if (assigned(operObject)) then begin IDKRestovina := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; //айдишники нужных свойств operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnConduitElmentSideDimensions); if (assigned(operObject)) then begin IDPropSide := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnConduitElmentSide1Dimensions); if (assigned(operObject)) then begin IDPropSide1 := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnConduitElmentSide2Dimensions); if (assigned(operObject)) then begin IDPropSide2 := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnConduitElmentSide3Dimensions); if (assigned(operObject)) then begin IDPropSide3 := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnConduitElmentSide4Dimensions); if (assigned(operObject)) then begin IDPropSide4 := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; operObject := F_NormBase.GSCSBase.NBSpravochnik.GetPropertyBySysName(pnCableCanalElemetType); if (assigned(operObject)) then begin IDPropTypeElement := TNBComponentType(operObject).ComponentType.ID; operObject := Nil; end; F_NormBase.DM.Query_Select.Close; F_NormBase.DM.Query_Select.SQL.Clear; Str := 'Select id from component where ID_COMPONENT_TYPE in (' + IntToStr(MasIDTypeCompon[0]); for i := 1 to MasIDTypeCompon.Count - 1 do begin Str := Str + ', ' + IntToStr(MasIDTypeCompon[i]); end; // id_property = ' + IntToStr(idProp_IdKolJil) + Str := Str + ') and id not in (select id_component from comp_prop_relation where id_property in ( ' + IntToStr(IDPropSide) + ', ' + IntToStr(IDPropSide1) + ', ' + IntToStr(IDPropSide2) + ', ' + IntToStr(IDPropSide3) + ', ' + IntToStr(IDPropSide4) + '))'; F_NormBase.DM.Query_Select.SQL.Text := Str; try F_NormBase.DM.Query_Select.ExecQuery; //F_NormBase.DM.Query_Select.; While not F_NormBase.DM.Query_Select.Eof do begin MasComponID.Add(F_NormBase.DM.Query_Select.Fields[0].AsInteger); F_NormBase.DM.Query_Select.Next; end; except end; //перебор всех компонентов for index := 0 to MasComponID.Count - 1 do begin operCompon.ID := MasComponID[index]; operCompon.LoadComponentByID(operCompon.ID); operCompon.LoadInterfaces(-1, false); operCompon.LoadProperties; //для начала определим тип элемента for i := 0 to operCompon.Properties.Count - 1 do begin if PProperty(operCompon.Properties[i]).ID_Property = IDPropTypeElement then begin TypeElement := StrToInt(PProperty(operCompon.Properties[i]).Value); break; end; end; case TypeElement of contTjoin, contAdapter, contAnglePlane, contAngleIn, contAngleOut, contCross: begin Kolside := 0; //sidesection := ''; for i := 0 to operCompon.Interfaces.Count-1 do begin for j := 0 to MasNeedInterfases.Count-1 do begin if operCompon.Interfaces[i].ID_Interface = MasNeedInterfases[j] then begin Kolside := Kolside + 1; GlobalMasValueProperty.Add(operCompon.Interfaces[i].SideSection); GlobalMasIDCompon.Add(operCompon.ID); case Kolside of 1: GlobalMasIDProperty.Add(IDPropSide1); 2: GlobalMasIDProperty.Add(IDPropSide2); 3: GlobalMasIDProperty.Add(IDPropSide3); 4: GlobalMasIDProperty.Add(IDPropSide4); end; end; end; end; if (kolside > 3) and (TypeElement = contTjoin) then begin GlobalMasTypeCompon.Add(IDKRestovina); end; if (kolside < 4 ) and (TypeElement = contTjoin) then begin GlobalMasTypeCompon.Add(IDTroynik); end; if (TypeElement = contAdapter) then begin GlobalMasTypeCompon.Add(IDAdapter); end; if (TypeElement = contAnglePlane) or (TypeElement = contAngleIn) or (TypeElement = contAngleOut) then begin GlobalMasTypeCompon.Add(IDUgol); end; end; contCork, contConnector, contWallCork: begin for i := 0 to operCompon.Interfaces.Count-1 do begin for j := 0 to MasNeedInterfases.Count-1 do begin if operCompon.Interfaces[i].ID_Interface = MasNeedInterfases[j] then begin GlobalMasValueProperty.Add(operCompon.Interfaces[i].SideSection); GlobalMasIDCompon.Add(operCompon.ID); GlobalMasIDProperty.Add(IDPropSide); break; end; end; end; if (TypeElement = contCork) then begin GlobalMasTypeCompon.Add(IDBlank); end; if (TypeElement = contConnector) then begin GlobalMasTypeCompon.Add(IDUnion); end; if (TypeElement = contWallCork) then begin GlobalMasTypeCompon.Add(IDVVod); end; end; else begin GlobalMasTypeCompon.Add(-1); end; end; end; //конец перебора компонентов //добавление необходимых свойств для компонентов F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'insert into comp_prop_relation (id_component, id_property, pvalue, guid) values (:par1, :par2, :par3, :par4)'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to GlobalMasIDCompon.Count - 1 do begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := GlobalMasIDCompon[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := GlobalMasIDProperty[index]; F_NormBase.DM.Query_Operat.Params[2].AsString := GlobalMasValueProperty[index]; F_NormBase.DM.Query_Operat.Params[3].AsString := CreateGUID; F_NormBase.DM.Query_Operat.ExecQuery; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Options := SaveOption; end; //меняем свойство тип компонента для крестовин F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'update comp_prop_relation set pvalue = :par1 where (id_component = :par2) and (id_property = ' + IntToStr(IDPropTypeElement) + ')'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to MasComponID.Count - 1 do begin if GlobalMasTypeCompon[index] = IDKRestovina then begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := contCross; F_NormBase.DM.Query_Operat.Params[1].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.ExecQuery; end; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Options := SaveOption; end; //меняем тип компонента F_NormBase.DM.Query_Operat.Close; SaveOption := F_NormBase.DM.Query_Operat.Options; F_NormBase.DM.Query_Operat.Options := F_NormBase.DM.Query_Operat.Options - [qoAutoCommit, qoStartTransaction]; try F_NormBase.DM.Query_Operat.SQL.Clear; F_NormBase.DM.Query_Operat.SQL.Text := 'update component set id_component_type = :par1 where id = :par2'; F_NormBase.DM.Query_Operat.Transaction.StartTransaction; F_NormBase.DM.Query_Operat.Prepare; for index := 0 to MasComponID.Count - 1 do begin if GlobalMasTypeCompon[index] > 0 then begin F_NormBase.DM.Query_Operat.Params[0].AsInteger := GlobalMasTypeCompon[index]; F_NormBase.DM.Query_Operat.Params[1].AsInteger := MasComponID[index]; F_NormBase.DM.Query_Operat.ExecQuery; end; end; F_NormBase.DM.Query_Operat.Transaction.Commit; finally F_NormBase.DM.Query_Operat.Options := SaveOption; end; finally MasComponID.Free; MasNeedInterfases.Free; operCompon.Free; MasIDTypeCompon.Free; GlobalMasValueProperty.Free; GlobalMasIDCompon.Free; GlobalMasIDProperty.Free; GlobalMasTypeCompon.Free; end; end; procedure LoadCADFromFile(const AFileName: String); var NewTab: TTabSheet; MenuItem: TMenuItem; i, j: integer; 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; //Tolik CadFigList: TList; // begin {GCadForm.PCad.OnObjectInserted := nil; GCadForm.PCad.LoadFromFile(AFile); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted;} //OpenListsInProject(GCadForm.FCADListID, ''); BeginProgress; try //TF_CAD.Create(FSCS_Main); //GCadForm.FCADListID := AListParams.ID; //GCadForm.FCADListName := AListParams.Name; //GCadForm.FCADProjectName := GetCurrProjectName; LoadSettingsForList(GCadForm.FCADListID, False); PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(GCadForm.FCADListID).Caption; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; if AFileName <> '' then begin // подгрузить из файла GCadForm.PCad.OnObjectInserted := nil; GCadForm.PCad.LoadFromFile(AFileName); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end; if (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 CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin if TConnectorObject(Figure).AsEndPoint then TConnectorObject(Figure).AsEndPoint := False; TConnectorObject(Figure).RaiseProperties(CadFigList); end; if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTFrame) then TFrame(Figure).RaiseProperties; if CheckFigureByClassName(Figure, cTPlanTrace) then TPlanTrace(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTPlanObject) then TPlanObject(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTPlanConnector) then TPlanConnector(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTCabinet) then TCabinet(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTCabinetExt) then TCabinetExt(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties(CadFigList); if CheckFigureByClassName(Figure, 'TRichText') then begin //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(Figure).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(Figure); end; if CheckFigureByClassName(Figure, cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(Figure); 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(Figure).RaiseProperties(CadFigList); end; end; FreeAndNil(CadFigList); // { 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 //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; 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; SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); FindObjectsForConvertClasses; //SetCADFrameParams(GCadForm); if GListRaiseWithErrors then begin ShowLog; GListRaiseWithErrors := False; end; end; 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 // Tolik 10/02/2021 -- else if GCadForm.FListType = lt_ElScheme then begin DisableOptionsForEl_Scheme; end //Tolik 06/02/2023 -- else if GCadForm.FListType = lt_AScheme then begin DisableOptionsForEl_Scheme; end; // SkipAllLinesShadows(GCadForm); // установить параметры листа от мастера создания листа // LoadSettingsForListByParams(AListParams); // SaveListParams(GCadForm.FCADListID, AListParams); except on E: Exception do addExceptionToLogEx('U_BaseCommon.LoadCADFromFile', E.Message); end; EndProgress; end; function CreatePDFObject(aOwner: TComponent; const aTitle:String; AFileName: string=''; aOutputStream: TStream=nil): TPDFDocument; var DC: HDC; begin Result := TPDFDocument.Create(aOwner); Result.ProtectionKeyLength := kl40; //06.03.2012 // Tolik 15/07/2019 -- если ProtectionEnabled = true, то подразумевается, что файл запаролен и ридеры потом будут просить пароль... // на delphi 6 такого не наблюдалось (может потому, что там компонента другая...в смысле, PDFToolKit) //Result.ProtectionEnabled := true; Result.ProtectionEnabled := False; // Result.ProtectionOptions := [coPrint, coModifyStructure, coCopyInformation, coModifyAnnotation, coPrintHi, coFillAnnotation, coExtractInfo, coAssemble]; Result.DocumentInfo.Title := aTitle; //название отчета Result.DocumentInfo.Subject := ''; Result.DocumentInfo.Producer := cResourceReport_Msg24 +ApplicationName+' '+VersionEXE; Result.DocumentInfo.Author := ExpertSoft_r; Result.DocumentInfo.Creator := ''; Result.DocumentInfo.Keywords := ''; Result.DocumentInfo.CreationDate := Now; Result.FileName := AFileName; Result.OutputStream := aOutputStream; Result.Compression := ctFlate; Result.JPEGQuality := 100; Result.NonEmbeddedFont.Add('WingDings'); Result.OnePass := True; DC := GetDC(0); Result.Resolution := GetDeviceCaps(dc, LOGPIXELSX); ReleaseDC(0, DC); //FPDF.BeginDoc; end; procedure SetCADPageParamsToPDF(ACad: TForm; aPDFDoc: TPDFDocument; AIsSubstrate: Boolean); var Bitmap: TBitmap; //px: extended; Form: TForm; dpm: Double; begin //case TF_CAD(ACad).PCad.PageLayout of // //plA0: // //plA1: // //plA2: // plA3: PDFDoc.CurrentPage.Size := psA3; // plA4: PDFDoc.CurrentPage.Size := psA4; // //plA5: // //plA6: // //plB4: // plB5: PDFDoc.CurrentPage.Size := psB5; // //plTabloid: // plLetter: PDFDoc.CurrentPage.Size := psLetter; // plCustom: PDFDoc.CurrentPage.Size := psUserDefined; // end; Bitmap := nil; if AIsSubstrate then Bitmap := TF_CAD(ACad).PCad.SaveSubstrateToBitmap(true) else Bitmap := TF_CAD(ACad).PCad.SaveToBitmap(true); case TF_CAD(ACad).PCad.PageOrient of PCTypesUtils.poPortrait: aPDFDoc.CurrentPage.Orientation := PDF.poPagePortrait; PCTypesUtils.poLandscape: aPDFDoc.CurrentPage.Orientation := PDF.poPageLandscape; end; // Tolik 19/12/2020 -- тут немножко переделано, чтолбы более-менее сохранить качество при том же формате листа // а то было как-то не очень (по качеству изображения) // aPDFDoc.CurrentPage.Width := Bitmap.Width; // aPDFDoc.CurrentPage.Height := Bitmap.Height; //if GCadForm.PCad.ZoomScale <> 100 then if not GExportUSeScale then begin //prDpm := DotsPerMilOrig; //Приводим лист ПДФ к формату страницы када { Dpm := GCadForm.PCad.DotsPerMilOrig; Form := GCadForm.PCad.GetForm; if Form <> nil then Dpm := (Form.PixelsPerInch / 25.4) * (300 / Form.PixelsPerInch);} Dpm := 300 / 25.4; {if GCadForm.PCad.ZoomScale < 200 then px := 0.25 else px := 100/GCadForm.PCad.ZoomScale;} //aPDFDoc.CurrentPage.Width := Round(Bitmap.Width*px); //aPDFDoc.CurrentPage.Height := Round(Bitmap.Height*px); aPDFDoc.CurrentPage.Width := Round(GCadForm.PCad.WorkWidth * dpm); aPDFDoc.CurrentPage.Height := Round(GCadForm.PCad.WorkHeight * dpm); {aPdfDoc.EMFImageAsJpeg := True; aPDFDoc.JPEGQuality := 100; aPDFDoc.Resolution := 300; aPDFDoc.Compression := ctFlate; } //aPDFDoc.CurrentPage.SetRGBColor(0.8,0.8,0.8); //aPDFDoc.CurrentPage.SetGrayFill(0); //aPDFDoc.CurrentPage.ShowImage(aPDFDoc.AddImage(Bitmap, itcFlate), 0, 0, aPDFDoc.CurrentPage.Width, aPDFDoc.CurrentPage.Height, 0); aPDFDoc.CurrentPage.ShowImage(aPDFDoc.AddImage(Bitmap, itcJpeg), 0, 0, aPDFDoc.CurrentPage.Width, aPDFDoc.CurrentPage.Height, 0); end else begin aPDFDoc.CurrentPage.Width := Bitmap.Width; aPDFDoc.CurrentPage.Height := Bitmap.Height; aPDFDoc.CurrentPage.ShowImage(aPDFDoc.AddImage(Bitmap, itcFlate), 0, 0, aPDFDoc.CurrentPage.Width, aPDFDoc.CurrentPage.Height, 0); end; //aPDFDoc.CurrentPage.ShowImage(aPDFDoc.AddImage(Bitmap, itcFlate), 0, 0, aPDFDoc.CurrentPage.Width, aPDFDoc.CurrentPage.Height, 0); //end; //aPDFDoc.CurrentPage.ShowImage(aPDFDoc.AddImage(Bitmap, itcJpeg), 0, 0, Bitmap.Width, Bitmap.Height, 0); Bitmap.Free; end; function GetClassPropList(AClass: TClass): TStringList; var pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; i: integer; begin Result := TStringList.Create; pInfo := AClass.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin Result.Add(propList[i].Name); end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; function GetPropertyObject(AObject: TObject; const APropName: String; AMinClass: TClass): TObject; begin Result := nil; if IsPublishedProp(AObject, APropName) then Result := GetObjectProp(AObject, APropName, AMinClass); end; function IsBoolTypeInfo(ATypeInfo: PTypeInfo): Boolean; begin Result := false; if ATypeInfo^.Kind = tkEnumeration then Result := GetTypeData(ATypeInfo)^.BaseType^ = TypeInfo(Boolean); end; function ObjectProps(AObject: TObject): TStringList; var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropName: String; begin Result := TStringList.Create; pInfo := AObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i]^.Name; if (PropName <> 'Name') and (PropName <> 'Tag') then Result.Add(PropName); end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure ObjectPropsToForm(AObject: TObject; AForm: TForm; APropPrefix:string='f'); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropName: String; PropValue: Variant; MainForm: TF_Main; PropsUOM: TStringList; TypeKind: TTypeKind; FormCompon: TComponent; begin pInfo := AObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin MainForm := TF_Main(GetPropertyObject(AForm, 'PropMainForm', TF_Main)); PropsUOM := TStringList(GetPropertyObject(AForm, 'PropsUOM', TStringList)); GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i]^.Name; TypeKind := propList[i]^.PropType^^.Kind; if (PropName <> 'Name') and (PropName <> 'Tag') then begin FormCompon := AForm.FindComponent(APropPrefix + PropName); if FormCompon <> nil then begin PropValue := GetPropValue(AObject, PropName); if TypeKind in [tkInteger, tkFloat] then if (MainForm <> nil) and (PropsUOM <> nil) and ((PropsUOM.Count = 0) or (PropsUOM.IndexOf(FormCompon.Name) <> -1)) then PropValue := RoundCP(FloatInUOM(PropValue, umMetr, MainForm.FUOM)); if FormCompon is TRzNumericEdit then begin TRzNumericEdit(FormCompon).Value := PropValue; end else if FormCompon is TRzCheckBox then TRzCheckBox(FormCompon).Checked := PropValue else if FormCompon is TRzEdit then TRzEdit(FormCompon).Text := PropValue end; end; end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure ObjectPropsFromForm(AObject: TObject; AForm: TForm; APropPrefix:string='f'); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropName: String; PropValue: Variant; MainForm: TF_Main; PropsUOM: TStringList; TypeKind: TTypeKind; FormCompon: TComponent; begin pInfo := AObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin MainForm := TF_Main(GetPropertyObject(AForm, 'PropMainForm', TF_Main)); PropsUOM := TStringList(GetPropertyObject(AForm, 'PropsUOM', TStringList)); GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i]^.Name; TypeKind := propList[i]^.PropType^^.Kind; if (PropName <> 'Name') and (PropName <> 'Tag') then begin FormCompon := AForm.FindComponent(APropPrefix + PropName); if FormCompon <> nil then begin PropValue := null; if FormCompon is TRzEdit then PropValue := TRzEdit(FormCompon).Text else if FormCompon is TRzNumericEdit then PropValue := TRzNumericEdit(FormCompon).Value else if FormCompon is TRzCheckBox then PropValue := TRzCheckBox(FormCompon).Checked; if PropValue <> null then begin if TypeKind in [tkInteger, tkFloat] then if (MainForm <> nil) and (PropsUOM <> nil) and ((PropsUOM.Count = 0) or (PropsUOM.IndexOf(FormCompon.Name) <> -1)) then PropValue := FloatInUOM(PropValue, MainForm.FUOM, umMetr); SetPropValue(AObject, PropName, PropValue); end; end; end; end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure ObjectPropsToSCSObj(AObject: TObject; ASCSObj: TObject); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropName: String; PropValue: Variant; IsBool: Boolean; TypeKind: TTypeKind; begin pInfo := AObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i]^.Name; TypeKind := propList[i]^.PropType^^.Kind; if (PropName <> 'Name') and (PropName <> 'Tag') then begin IsBool := IsBoolTypeInfo(propList[i]^.PropType^); PropValue := GetPropValue(AObject, PropName); if IsBool then PropValue := BoolToInt(PropValue); TSCSComponCatalogClass(ASCSObj).SetPropertyValueAsString(AnsiUpperCase(PropName), PropValue, false); end; end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure ObjectPropsToSCSChild(AObject: TObject; ASCSObj: TObject; AChildIsLine: Integer); var Child: TSCSComponent; begin if (AObject <> nil) and (ASCSObj <> nil) and (ASCSObj is TSCSComponent) then begin Child := GetChildComponByIsLine(TSCSComponent(ASCSObj), AChildIsLine); if Child <> nil then ObjectPropsToSCSObj(AObject, Child); end; end; procedure ObjectPropsFromSCSObj(AObject: TObject; ASCSObj: TObject); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropTypeKind: TTypeKind; PropName: String; PropNameU: String; PropValue: Variant; IsBool: Boolean; PropInfo: PPropInfo; PropTypeInfo: PTypeInfo; DoubleVal: Double; begin pInfo := AObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i].Name; if (PropName <> 'Name') and (PropName <> 'Tag') then begin PropNameU := AnsiUpperCase(PropName); PropValue := null; PropTypeKind := propList[i].PropType^.Kind; if PropTypeKind = tkFloat then PropValue := TSCSComponCatalogClass(ASCSObj).GetPropertyValueAsFloat(PropNameU) else PropValue := TSCSComponCatalogClass(ASCSObj).GetPropertyValueBySysName(PropNameU); if PropValue <> null then begin try PropInfo := propList[i]; //PropTypeInfo := GetTypeData(PropInfo^.PropType^)^.BaseType^;// = TypeInfo(Boolean) IsBool := IsBoolTypeInfo(propList[i]^.PropType^); if IsBool then begin if PropValue <> '' then PropValue := IntToBool(PropValue) else PropValue := false; end else if PropInfo^.PropType^^.Kind in [tkFloat, tkInteger, tkInt64] then begin try DoubleVal := PropValue; except PropValue := 0; end; end; SetPropValue(AObject, PropName, PropValue); except on E: Exception do AddExceptionToLogEx('ObjectPropsFromSCSObj', E.Message); end; end; end; end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure ObjectPropsFromSCSChild(AObject: TObject; ASCSObj: TObject; AChildIsLine: Integer); var Child: TSCSComponent; begin if ASCSObj is TSCSComponent then begin Child := GetChildComponByIsLine(TSCSComponent(ASCSObj), AChildIsLine); if Child <> nil then ObjectPropsFromSCSObj(AObject, Child); end; end; procedure ObjectPropsToObj(ASrcObject, ATrgObject: TObject); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; PropName: String; PropValue: Variant; begin pInfo := ASrcObject.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} propCnt := pType^.PropCount; if propCnt > 0 then begin GetMem(propList, sizeOf(PPropInfo) * propCnt); try GetPropInfos(pInfo, propList); for i := 0 to propCnt - 1 do begin PropName := propList[i].Name; if (PropName <> 'Name') and (PropName <> 'Tag') then if IsPublishedProp(ATrgObject, PropName) then begin PropValue := GetPropValue(ASrcObject, PropName); SetPropValue(ATrgObject, PropName, PropValue); end; end; finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; procedure SetFormControlDisplayFormat(AForm: TForm); var i: Integer; Compon: TComponent; begin for i := 0 to AForm.ComponentCount - 1 do begin Compon := AForm.Components[i]; if Compon is TRzNumericEdit then begin //if Compon.Name <> 'fBasementColumnCount' then if Not TRzNumericEdit(Compon).IntegersOnly then TRzNumericEdit(Compon).DisplayFormat := GetDisplayFormatForFloat else TRzNumericEdit(Compon).DisplayFormat := ',0'; //TRzNumericEdit(Compon). end; end; end; function KeyExistsInReg(ARootKey: DWORD; const AKey: String): Boolean; var Reg: TRegistry; begin Result := false; Reg := TRegistry.Create; try Reg.RootKey := HKEY_CLASSES_ROOT; Result := Reg.KeyExists(AKey); finally Reg.Free; end; end; function IsOOInstalled: Boolean; begin Result := KeyExistsInReg(HKEY_CLASSES_ROOT, 'com.sun.star.ServiceManager'); //Result := false; end; function IsWordInstalled: Boolean; //var // Reg: TRegistry; //s: string; begin //Reg := TRegistry.Create; //try // Reg.RootKey := HKEY_CLASSES_ROOT; // Result := Reg.KeyExists('Word.Application'); //finally // Reg.Free; //end; Result := KeyExistsInReg(HKEY_CLASSES_ROOT, 'Word.Application'); //Result := false; end; procedure OpenProgram(const prog, params: string); var c, p: array[0..800] of Char; begin StrPCopy(c, prog); StrPCopy(p, params); ShellExecute(Application.Handle, 'open', c, p, nil, SW_NORMAL); end; procedure ReloadProgram; var ExeLoader: String; ProgParams: String; i: integer; begin try ExeLoader := GetPathToExeLoader; if FileExists(ExeLoader) then begin ProgParams := GetShortFilePath(ParamStr(0)); // Если программа запущена с параметрами, то подхватываем их for i := 1 to ParamCount do begin if ProgParams <> '' then ProgParams := ProgParams + ' '; ProgParams := ProgParams + ParamStr(i); end; //ShowMessage(GetShortFilePath(ExeLoader)+' '+GetShortFilePath(ProgParams)); OpenProgram(ExeLoader, ProgParams); end; except on E: Exception do AddExceptionToLogEx('ReloadProgram', E.Message); end; TerminateProgramm; end; procedure StreamToOLEStream(AStream: TStream; AOutOLEStream: TStream); const s = 'BDOC'; var i: Integer; begin AStream.Position := 0; //stream2:=TMemoryStream.Create; AOutOLEStream.Position := 0; AOutOLEStream.Write(s[1],4); i:=DVASPECT_CONTENT; AOutOLEStream.Write(i,4); i:= AStream.Size; AOutOLEStream.Write(i,4); AOutOLEStream.CopyFrom(AStream, AStream.Size); AOutOLEStream.Position := 0; end; procedure TerminateProgramm; begin {$if Defined(ES_GRAPH_SC)} Application.Terminate; {$else} ExitProcess(0); {$ifend} end; procedure InitGlobalObjects; var WireCompTypes: TStringList; ChannelSideTypes: TStringList; begin GSQLMTSignatures := TStringList.Create; GSQLMTSignatures.Add(#$41+#$43+#$53+#$31+#$3D+#$0A+#$D7+#$A3+#$70+#$3D+#$08+#$40+#$01+#$00); // ACS1=xxrp=xxx SQLMemTable 3.03 GSQLMTSignatures.Add(#$41+#$43+#$53+#$31+#$66+#$66+#$66+#$66+#$66+#$66+#$08+#$40+#$01+#$00); // ACS1ffffffxxx SQLMemTable 3.05 // Tolik 31/07/2019 -- GSQLMTSignatures.Add(#$41+#$43+#$53+#$35+#$00+#$00+#$00+#$00+#$00+#$00+#$22+#$40+#$01+#$00); // ACS5 - текущая версия GExecuteLog := TStringList.Create; GCompTypeSysNameCables := TStringList.Create; GCompTypeSysNameCables.Add(ctsnCable); GCompTypeSysNameCables.Add(ctsnOFCable); GCompTypeSysNameCableChannels := TStringList.Create; GCompTypeSysNameCableChannels.Add(ctsnCableChannel); GCompTypeSysNamePanels := TStringList.Create; GCompTypeSysNamePanels.Add(ctsn19InchPanel); GCompTypeSysNamePanels.Add(ctsnPatchPanel); GCompTypeSysNamePanels.Add(ctsnTerminalBloc); GCompTypeSysNameModules := TStringList.Create; GCompTypeSysNameModules.Add(ctsnModule); GCompTypeSysNameModules.Add(ctsnSocket); GCompTypeSysNameModules.Add(ctsnOFModule); GCompTypeSysNameModules.Add(ctsnOFConnector); GCompTypeSysNameModules.Add(ctsnConnector); GCompTypeSysNameModules.Add(ctsnConnectingModule); GCompTypeSysNameModules.Add(ctsnLamp); // Tolik 01/03/2021 -- GCompTypeSysNameComplexCompons := TStringList.Create; GCompTypeSysNameComplexCompons.Add(ctsnCrossATS); GCompTypeSysNameComplexCompons.Add(ctsnDistributionCabinet); GCompTypeSysNameComplexCompons.Add(ctsnHouse); GPropSysNameInUOM := TStringList.Create; GPropSysNameInUOM.Sorted := true; GPropSysNameInUOM.Add(pnBasementColumnH); GPropSysNameInUOM.Add(pnBasementColumnW); GPropSysNameInUOM.Add(pnBasementColumnL); GPropSysNameInUOM.Add(pnBasementThickness); GPropSysNameInUOM.Add(pnBottomBound); GPropSysNameInUOM.Add(pnCoordZ); GPropSysNameInUOM.Add(pnDepth); //GPropSysNameInUOM.Add(pnExpenseForMetr); GPropSysNameInUOM.Add(pnHeight); GPropSysNameInUOM.Add(pnHeightRoom); GPropSysNameInUOM.Add(pnHeightCeiling); GPropSysNameInUOM.Add(pnHeightSocket); GPropSysNameInUOM.Add(pnHeightCorob); GPropSysNameInUOM.Add(pnHeightOfPlacing); GPropSysNameInUOM.Add(pnHeightSide1); GPropSysNameInUOM.Add(pnHeightSide2); GPropSysNameInUOM.Add(pnHeightWalls); GPropSysNameInUOM.Add(pnLeftBound); GPropSysNameInUOM.Add(pnLength); GPropSysNameInUOM.Add(pnLengthProj); GPropSysNameInUOM.Add(pnPerimeter); GPropSysNameInUOM.Add(pnPerimeterCeil); GPropSysNameInUOM.Add(pnPerimeterFloor); GPropSysNameInUOM.Add(pnPerimeterFloorFull); GPropSysNameInUOM.Add(pnPerimeterOut); GPropSysNameInUOM.Add(pnPerimeterSlope); GPropSysNameInUOM.Add(pnPlinthThickness); GPropSysNameInUOM.Add(pnReservAtPointCompon); GPropSysNameInUOM.Add(pnReservThroughPointCompon); GPropSysNameInUOM.Add(pnRightBound); GPropSysNameInUOM.Add(pnSectionSize); GPropSysNameInUOM.Add(pnSlotWidth); GPropSysNameInUOM.Add(pnTopBound); GPropSysNameInUOM.Add(pnTrenchDepth); // Глубина траншеи GPropSysNameInUOM.Add(pnTwistedPairMaxLength); GPropSysNameInUOM.Add(pnWidth); GPropSysNameInUOM.Add(pnWidthOut); GPropSysNameInUOM.Add(pnPlinthHeight); //GPropSysNameInUOM.Add(pnPlinthHeightFromGround); GPropSysNameInUOM.Add(pnBasementDepth); GPropSysNameInUOM.Add(pnBasementTotalHeight); GPropSysNameInUOM.Add(pnMaterialHeight); GPropSysNameInUOM.Add(pnMaterialHeightUsable); GPropSysNameInUOM.Add(pnMaterialWidth); GPropSysNameInUOM.Add(pnMaterialWidthUsable); GPropSysNameInUOM.Add(pnContiguityFromPerimetr); GPropSysNameInUOM.Add(pnDescentSize); // Размер спуска = 0.05м GPropSysNameInUOM.Add(pnVentSideSize); // Размер бокового напуска = 0.07м GPropSysNameInUOM.Add(pnRemainsMinUseSize); //Мин. размер остатков для использования GPropSysNameInUOM.Add(pnTypeSize1); // Типоразмер 1 GPropSysNameInUOM.Add(pnTypeSize2); // Типоразмер 2 GPropSysNameInUOM.Add(pnTypeSize3); // Типоразмер 3 GPropSysNameInUOM.Add(pnTypeSize4); // Типоразмер 4 //GPropSysNameInUOM.Sort; //GPropSysNameInUOM.SaveToFile('c:\propsysnames.txt'); GPropSysNameInUOM.Add(pnPerimeterEmbrasures); GPropSysNameInUOM.Add(pnOverlapping); // Перекрытие GPropSysNameInUOM.Add(pnOverlappingLateral); // Перекрытие боковое GPropSysNameInUOM.Add(pnRoofBaseRadius); // Tolik -- 03/11/2017 GPropSysNameInUOM.Add('ACT_RANGE'); // дальность действия (например, для видеокамер) GPropSysNameInUOM.Add('F_OFFSET'); // смещение (например, для видеокамер) GPropSysNameInUOM.Add('ID_HEIGHT'); // высота обнаружения (например, для видеокамер) // //Tolik 11/02/2022 -- для 3Д моделек (свойства) GPropSysNameInUOM.Add('3D_HEIGHT'); GPropSysNameInUOM.Add('3D_LENGTH'); GPropSysNameInUOM.Add('3D_WIDTH'); //GPropSysNameInUOM.Add('K_3DMODEL_OFF_X'); //GPropSysNameInUOM.Add('K_3DMODEL_OFF_Y'); //GPropSysNameInUOM.Add('K_3DMODEL_OFF_Z'); // GPropSysNameInUOM2 := TStringList.Create(); GPropSysNameInUOM2.Sorted := true; GPropSysNameInUOM2.Add(pnBasementArea); GPropSysNameInUOM2.Add(pnPlinthSidesSquare); GPropSysNameInUOM2.Add(pnPlinthSurfaceSquare); GPropSysNameInUOM2.Add(pnSquare); GPropSysNameInUOM2.Add(pnSquareCeil); GPropSysNameInUOM2.Add(pnSquareFloor); GPropSysNameInUOM2.Add(pnSquareEmbrasureLess); GPropSysNameInUOM2.Add(pnSquareExceptEmbrasureSlopeLess); GPropSysNameInUOM2.Add(pnSquareInclEmbrasureSlope); GPropSysNameInUOM2.Add(pnSquareOut); GPropSysNameInUOM2.Add(pnSquarePlasterboardPerimetr); GPropSysNameInUOM2.Add(pnSquareSlope); //GPropSysNameInUOM2.Add(pnWallDivSquareExceptEmbrasureSlopeLess); GPropSysNameInUOM2.Add(pnWallSquare); GPropSysNameInUOM2.Add(pnWallsOutSquare); // внешняя площадь стен GPropSysNameInUOM2.Add(pnWallsSquare); GPropSysNameInUOM2.Add(pnWallSquareEmbrasureLess); GPropSysNameInUOM2.Add(pnWallSquareExceptEmbrasureSlopeLess); GPropSysNameInUOM2.Add(pnWallSquareInclEmbrasureSlope); GPropSysNameInUOM2.Add(pnAreaWithRemains); GPropSysNameInUOM2.Add(pnSquareInclEmbrasures); //Площадь с учетом проемов GPropSysNameInUOM2.Add(pnSquareInclEmbrasuresLap); //Площадь с учетом проемов/напусков GPropSysNameInUOM3 := TStringList.Create; GPropSysNameInUOM3.Sorted := true; GPropSysNameInUOM3.Add(pnBasementColumnVBetwCorner); GPropSysNameInUOM3.Add(pnBasementColumnV); GPropSysNameInUOM3.Add(pnPlinthVolume); //Объем цоколя // Объем фундамента над землей //GPropSysNameInUOM3.Add(pnBasementVolumeunderGround); // Объем фундамента под землей GPropSysNameInUOM3.Add(pnTrenchVolume); // Объем траншеи GPropSysNameInUOM3.Add(pnBasementVolume); // Объем фундамента GPropSysNameInUOM3.Add(pnWallsVolume); // Объем стен GPropSysNameInUOM3.Add(pnVolume); // Объем // Расчетные свойства GPropSysNameCalc := TStringList.Create; GPropSysNameCalc.Sorted := true; GPropSysNameCalc.Add(pnSquare); GPropSysNameCalc.Add(pnPerimeter); GPropSysNameCalc.Add(pnPerimeterCeil); GPropSysNameCalc.Add(pnPerimeterFloor); GPropSysNameCalc.Add(pnPerimeterFloorFull); GPropSysNameCalc.Add(pnPerimeterOut); GPropSysNameCalc.Add(pnPerimeterSlope); GPropSysNameCalc.Add(pnSquareOut); GPropSysNameCalc.Add(pnSquareCeil); GPropSysNameCalc.Add(pnSquareFloor); GPropSysNameCalc.Add(pnSquareEmbrasureLess); GPropSysNameCalc.Add(pnSquareExceptEmbrasureSlopeLess); GPropSysNameCalc.Add(pnSquareInclEmbrasureSlope); GPropSysNameCalc.Add(pnSquareSlope); GPropSysNameCalc.Add(pnSquarePlasterboardPerimetr); //GPropSysNameCalc.Add(pnWallDivSquareExceptEmbrasureSlopeLess); GPropSysNameCalc.Add(pnWallSquare); GPropSysNameCalc.Add(pnWallsSquare); GPropSysNameCalc.Add(pnWallSquareEmbrasureLess); GPropSysNameCalc.Add(pnWallSquareExceptEmbrasureSlopeLess); GPropSysNameCalc.Add(pnWallSquareInclEmbrasureSlope); GPropSysNameCalc.Add(pnBasementTotalHeight); GPropSysNameCalc.Add(pnPlinthVolume); GPropSysNameCalc.Add(pnPlinthSidesSquare); GPropSysNameCalc.Add(pnPlinthSurfaceSquare); GPropSysNameCalc.Add(pnBasementArea); GPropSysNameCalc.Add(pnBasementVolume); GPropSysNameCalc.Add(pnTrenchVolume); GPropSysNameCalc.Add(pnWallsOutSquare); GPropSysNameCalc.Add(pnBasementColumnVBetwCorner); GPropSysNameCalc.Add(pnWallsVolume); GPropSysNameCalc.Add(pnVolume); GPropSysNameCalc.Add(pnAreaWithRemains); GPropSysNameCalc.Add(pnContiguityFromPerimetr); GPropSysNameCalc.Add(pnCuttingWithRemains); GPropSysNameCalc.Add(pnPerimeterEmbrasures); GPropSysNameCalc.Add(pnTypeSize1ElCount); GPropSysNameCalc.Add(pnTypeSize2ElCount); GPropSysNameCalc.Add(pnTypeSize3ElCount); GPropSysNameCalc.Add(pnTypeSize4ElCount); GPropSysNameCalc.Add(pnSquareInclEmbrasures); GPropSysNameCalc.Add(pnSquareInclEmbrasuresLap); GPropRequired := CreateStringListSorted; GPropRequired.Add(pnInSection); // Внутреннее сечение GPropRequired.Add(pnOutSection); // Внешнее сечение GPropRequired.Add(pnPortCount); // Количество портов GPropRequired.Add(pnPortWireCount); // Количество жил на порт GPropRequired.Add(pnWireCount); // Количество жил GPropRequired.Add(pnCableCanalElemetType); // Тип элемента каб канала GPropRequired.Add(pnConduitSideDimensions); // Размеры сторон кабельного канала GPropRequired.Add(pnConduitElmentSideDimensions); // Размеры стороны элемента канала GPropRequired.Add(pnConduitElmentSide1Dimensions); // Размеры стороны 1 элемента канала GPropRequired.Add(pnConduitElmentSide2Dimensions); // Размеры стороны 2 элемента канала GPropRequired.Add(pnConduitElmentSide3Dimensions); // Размеры стороны 3 элемента канала GPropRequired.Add(pnConduitElmentSide4Dimensions); // Размеры стороны 4 элемента канала GPropRequiredIndexInSection := GPropRequired.IndexOf(pnInSection); // Внутреннее сечение GPropRequiredIndexOutSection := GPropRequired.IndexOf(pnOutSection); // Внешнее сечение GPropRequiredIndexPortCount := GPropRequired.IndexOf(pnPortCount); // Количество портов GPropRequiredIndexPortWireCount := GPropRequired.IndexOf(pnPortWireCount); // Количество жил на порт GPropRequiredIndexWireCount := GPropRequired.IndexOf(pnWireCount); // Количество жил GPropRequiredIndexCableCanalElemetType := GPropRequired.IndexOf(pnCableCanalElemetType); // Тип элемента каб канала GPropRequiredIndexConduitSideDimensions := GPropRequired.IndexOf(pnConduitSideDimensions); // Размеры сторон кабельного канала GPropRequiredIndexConduitElmentSideDimensions := GPropRequired.IndexOf(pnConduitElmentSideDimensions); // Размеры стороны элемента канала GPropRequiredIndexConduitElmentSide1Dimensions := GPropRequired.IndexOf(pnConduitElmentSide1Dimensions); // Размеры стороны 1 элемента канала GPropRequiredIndexConduitElmentSide2Dimensions := GPropRequired.IndexOf(pnConduitElmentSide2Dimensions); // Размеры стороны 2 элемента канала GPropRequiredIndexConduitElmentSide3Dimensions := GPropRequired.IndexOf(pnConduitElmentSide3Dimensions); // Размеры стороны 3 элемента канала GPropRequiredIndexConduitElmentSide4Dimensions := GPropRequired.IndexOf(pnConduitElmentSide4Dimensions); // Размеры стороны 4 элемента канала // Тимпы компонентов, к которым может подключаться универсальный интерфейс Жила WireCompTypes := CreateStringListSorted; WireCompTypes.AddStrings(GCompTypeSysNameCables); WireCompTypes.AddStrings(GCompTypeSysNamePanels); WireCompTypes.AddStrings(GCompTypeSysNameModules); WireCompTypes.AddStrings(GCompTypeSysNameComplexCompons); WireCompTypes.Add(ctsnCupboard); WireCompTypes.Add(ctsnAdapter); WireCompTypes.Add(ctsnAnalyser); WireCompTypes.Add(ctsnBox); WireCompTypes.Add(ctsnTwoPinPlug); WireCompTypes.Add(ctsnPlugSwitch); WireCompTypes.Add(ctsnProtectionIU); WireCompTypes.Add(ctsnConnectorBlock); WireCompTypes.Add(ctsnConnector); WireCompTypes.Add(ctsnCase); WireCompTypes.Add(ctsnCrossConnections); WireCompTypes.Add(ctsnCrossPointObject); WireCompTypes.Add(ctsnEquipment); WireCompTypes.Add(ctsnOrganizer); WireCompTypes.Add(ctsnPatchCord); WireCompTypes.Add(ctsnTerminalBloc); WireCompTypes.Add(ctsnWire); WireCompTypes.Add(ctsnWorkPlace); WireCompTypes.Add(ctsnJoiner); WireCompTypes.Add(ctsnTestingAccessory); WireCompTypes.Add(ctsnInstallBox); WireCompTypes.Add(ctsnJackPlug); WireCompTypes.Add(ctsnShield); WireCompTypes.Add(ctsnCrossATS); WireCompTypes.Add(ctsnDistributionCabinet); WireCompTypes.Add(ctsnTerminalBox); WireCompTypes.Add(ctsnLamp); WireCompTypes.Add(ctsnAutoSwitch); WireCompTypes.Add(ctsnHouse); WireCompTypes.Add(ctsnApproach); //08.02.2011 Тимпы компонентов, к которым может подключаться универсальный интерфейс сторона каб.канала ChannelSideTypes := CreateStringListSorted; ChannelSideTypes.AddStrings(GCompTypeSysNameCableChannels); ChannelSideTypes.Add(ctsnCableChannelElement); ChannelSideTypes.Add(ctsnAccessory); ChannelSideTypes.Add(ctsnCableChannelAccessory); ChannelSideTypes.Add(ctsnOther); ChannelSideTypes.Add(ctsnCork); ChannelSideTypes.Add(ctsnFrame); ChannelSideTypes.Add(ctsnTube); GUniversalInterfaces := CreateStringListSorted; GUniversalInterfaces.Add(guidUniversalInterface); GUniversalInterfaces.Add(guidUniversalPort); GUniversalInterfaces.AddObject(guidUniversalWire, WireCompTypes); GUniversalInterfaces.Add(guidUniversalOutConstr); GUniversalInterfaces.Add(guidUniversalInConstr); //06.10.2011 GUniversalInterfaces.Add(guidUniversalChannelSide); //08.02.2011 на будущее GUniversalInterfaces.AddObject(guidUniversalChannelSide, ChannelSideTypes); GUniversalInterfaces.AddObject(guidUniversalChannelSide, ChannelSideTypes); //GLiteVersion := false; //GUseLiteFunctional := true; //GUseArhOnlyMode := false; //GUseComponTemplates := Not GLiteVersion; //GUseVisibleInterfaces := Not GLiteVersion; //GUseVisibleInterfaces := true; end; initialization InitGlobalObjects; finalization GSQLMTSignatures.Free; GSQLMTSignatures := nil; GExecuteLog.Free; GExecuteLog := nil; FreeAndNil(GCompTypeSysNameCables); FreeAndNil(GCompTypeSysNameCableChannels); FreeAndNil(GCompTypeSysNamePanels); FreeAndNil(GCompTypeSysNameModules); FreeAndNil(GCompTypeSysNameComplexCompons); FreeAndNil(GPropSysNameCalc); FreeAndNil(GPropSysNameInUOM); FreeAndNil(GPropSysNameInUOM2); FreeAndNil(GPropSysNameInUOM3); FreeAndNil(GPropRequired); FreeStringsObjects(GUniversalInterfaces, true); FreeAndNil(GUniversalInterfaces); end. //BASEMENT_THICKNESS_UNDER_GROUND BASEMENT_THICKNESS //BASEMENT_THICKNESS_ABOVE_GROUND PLINTH_THICKNESS //BASEMENT_VOLUME_ABOVE_GROUND PLINTH_VOLUME