Знайти полігони з шарів зі стилем "тільки полігон" у статусі "правка", що частково/повністю накладаються на інші полігони того-ж шару, чи будь-яких шарів стилю "тільки полігон" у статусі "правка".
Наведений скрипт - спроба компенсувати відсутність функції [Overlay] серед доступних для написання сценарію контроля. Допрацьовувати скрипт спільними зусиллями, при бажанні та необхідності, прошу в темі "Все про скрипти".
;Перевірка наявності відкритої карти $CountMap=@MapCount @If $CountMap=0 then @Break Для перевірки накладання ділянок відкрийте карту ;Отримуєм перелік шарів зі стилем тільки полігон що в статусі правка $CounObgAll=@Map.Count $CountLay=@Map.Layers.Count $I=0 $StrOllLayPolig= @Progress.Start $CountLay Перебираю шари карти %StartLayList $I=$I+1 @If $I>$CountLay @Goto %EndLeyList @Progress.StepBy $LayPolig=@Map.Layers.Polygon $I @If $LayPolig=0 @Goto %StartLayList $LayAttrib=@Map.Layers.GetAttributes $I $StatLay=@StringPart 7 $LayAttrib @If $StatLay<>0 then @Goto %StartLayList @Map.CalculateRange $CountObgLayPolig=@Map.Layers.ObjectCount $I @If $CountObgLayPolig=0 @Goto %StartLayList $StrLayPolig=@Map.Layers.Get $I $IDLayPolig=@StringPart 1 $StrLayPolig $StrOllLayPolig=$StrOllLayPolig ID$IDLayPolig @Text.Add $StrLayPolig @Goto %StartLayList %EndLeyList @Progress.Stop ;Вносим допуск по площі перекриття, вибираєм шар, що будем контролювати на накладку, з переліку шарів $Dopusk=@Dialog.Ask Вкажіть максимально допустиме значення площі перекриття|(в розмірності нульового параметра карти) Default=1.0 Size=255 $Dopusk=@Calc Numeric("$Dopusk") $TextLayPolig=@Text.Text $LayControl=@Dialog.ListSelect Виберіть шари, накладки на які треба знайти|Всі шари зі стилем тільки полігон|$TextLayPolig @If "$LayControl"="" then @Break @If $LayControl<>Всі шари зі стилем тільки полігон then $StrOllLayPolig=@StringPart 1 $LayControl @If $LayControl<>Всі шари зі стилем тільки полігон then $StrOllLayPolig=ID$StrOllLayPolig @Map.DeselectAll @Map.BeginUpdate @Map.SelectLayer $StrOllLayPolig ;Отримуєм перелік номерів об'єктів, накладку з якими треба шукати $ListObjControl=@Map.Selected.List @Text[1].Text=$ListObjControl @Map.DeselectAll $ListObjCount=@Text[1].Count $I=0 @Progress.Start $ListObjCount Перебираю полігони ;Перебираєм об'єкти, перекриття з якими треба знайти %StartObgList $I=$I+1 @Progress.StepBy @If $I>$ListObjCount @Goto %EndObgList $NumObg=@Text[1].Line[$I] @If $LayControl=Всі шари зі стилем тільки полігон then $ObjOverlayList=@Map.Object[$NumObg].OverlayList else $ObjOverlayList=@Map.Object[$NumObg].OverlayList $StrOllLayPolig @If $ObjOverlayList= @Goto %StartObgList @Text[2].Text=$ObjOverlayList $CountObgOverlay=@Text[2].Count $I1=0 ;;Перебираєм об'єкти, що накривають об'єкт $NumObg %StartObgOverlayList $I1=$I1+1 @If $I1>$CountObgOverlay @Goto %EndObgOverlayList $NumObgOverlay=@Text[2].Line[$I1] @Map.DeselectAll ;;Виловлюєм об'єкти, що перекривають полігон, заведені як полігон але не зі стилем "тільки полігон" $IDLayObgOverlay=@Map.Object[$NumObgOverlay].LayerID $StyleLayObgOverlay=@Map.Layers.Polygon ID$IDLayObgOverlay @If $StyleLayObgOverlay=0 @Goto %StartObgOverlayList ;;Визначаєм площу перекриття полігонів @Map.Object[$NumObg].Select @Map.Object[$NumObgOverlay].Select $CounObgAll=$CounObgAll+1 @Map.Undo.StartOperationGroup ;;;Якщо результатом функції spbIntersect є створений полігон - його номер останній в карті ;;;Якщо кількість об'єктів не збільшилась - перекриття не вважається накладкою полігонів. @ExecuteMenu spbIntersect $CountObgAllNew=@Map.Count @If $CounObgAll=$CountObgAllNew @Goto %BeforPresentOverlay $CounObgAll=$CounObgAll-1 @Goto %StartObgOverlayList %BeforPresentOverlay $ShapeObgCreate=@Map.Object[$CounObgAll].Parameter[0] $ShapeObgCreate=@Calc Numeric("$ShapeObgCreate") @If $ShapeObgCreate>$Dopusk @Goto %PresentOverlay %NextOverlay @Map.Undo.Undo @Goto %StartObgOverlayList %EndObgOverlayList @Goto %StartObgList %EndObgList @Map.DeselectAll @Progress.Stop $TextListOverlay=@Text[3].Text ;Оцінюєм результат @Map.EndUpdate $CountLineOverlay=@Text[3].Count @If $CountLineOverlay=0 @Break Не знайдено жодного перекриття полігонів за вказаними умовами пошуку. ;Пропонуйте, будь-ласка, що робити зі знайденими полігонами $ResAsk=@Dialog.Select Перелік полігонів з перекриттям зформовано. Як оформити результат:|копіювати всі полігони, що перекриваються, на чисту карту|зберегти текстовий файл з переліком пар об'єктів що перекриваються|створити групи пар об'єктів, що перекриваються @If "$ResAsk"="копіювати всі полігони, що перекриваються, на чисту карту" then @Goto %ResAsk1 @If "$ResAsk"="зберегти текстовий файл з переліком пар об'єктів що перекриваються" then @Goto %ResAsk2 ;;Дописувати інші варіанти збереження результатів @Break Функціональність недопрацьована ; ;Копіюєм всі полігони, що перекриваються, на чисту карту %ResAsk1 $CountPresentOverlay=@Text[3].Count $I3=0 %StartPresentOverlay $I3=$I3+1 @If $I3>$CountPresentOverlay @Goto %EndPresentOverlay $StrI3=@Text[3].Line[$I3] $ObgOverlay1=@StringPart 1 $StrI3 $ObgOverlay2=@StringPart 2 $StrI3 @Map.Object[$ObgOverlay1].Select @Map.Object[$ObgOverlay2].Select @Goto %StartPresentOverlay %EndPresentOverlay @Map.Selected.Copy ;;Створюєм чисту карту $MapName=@Map.ClearShortFilename $NewMapName=$MapName-накладки @FileNew $NewMapName @Map.Paste @Map.CalculateRange @Dialog.Message В активній карті - лише ті полігони, що мають перекриття.|В карті $MapName - позначені полігони з накладкою. @Window.ShowSelected @Break ; %ResAsk2 $CountPresentOverlay=@Text[3].Count $I3=0 %StartPresentOverlayAsk2 $I3=$I3+1 @If $I3>$CountPresentOverlay @Goto %EndPresentOverlayAsk2 $StrI3=@Text[3].Line[$I3] $ObgOverlay1=@StringPart 1 $StrI3 $ObgOverlay2=@StringPart 2 $StrI3 @Map.Object[$ObgOverlay1].Select @Map.Object[$ObgOverlay2].Select @Text[4].Add Об'єкт №$ObgOverlay1 перекривається з об'єктом №$ObgOverlay2 @Goto %StartPresentOverlayAsk2 %EndPresentOverlayAsk2 ;;Записуєм текстовий файл $MapName=@Map.ClearFilename $FileNameOverlay=$MapName-накладки.txt @Text[4].Save $FileNameOverlay @Window.ShowSelected $Text=@Text[4].Text @Dialog.Message Знайдено:||$Text||Записано в файл $FileNameOverlay @Break ; ;Перебираєм знайдені раніше перекриття, для уникнення повтору рядків з парами об'єктів %PresentOverlay $CountLineOverlay=@Text[3].Count @If $CountLineOverlay=0 then @Text[3].Add $NumObg $NumObgOverlay @If $CountLineOverlay=0 @Goto %NextOverlay $I2=0 %StartLineOverlay $I2=$I2+1 @If $I2>$CountLineOverlay then @Text[3].Add $NumObg $NumObgOverlay @If $I2>$CountLineOverlay @Goto %NextOverlay $TestStr=@Text[3].Line[$I2] @If "$TestStr"="$NumObgOverlay $NumObg" then @Goto %NextOverlay @Goto %StartLineOverlay
|