Аналитика

Цифровая фотограмметрия, картография и землеустройство
Текущее время: 18 ноя 2017 21:17

Часовой пояс: UTC + 2 часа




Начать новую тему Ответить на тему  [ Сообщений: 161 ]  На страницу Пред.  1, 2, 3, 4, 5 ... 11  След.
Автор Сообщение
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 28 фев 2013 09:22 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Копирование значения заданного параметра из внешнего объекта из другой карты.

Данный скрипт для помеченного объекта карты находит внешний объект в другой карте, копирует из внешнего объекта значение заданного параметра и присваивает его исходному объекту. Чтобы скрипт сработал, помеченный объект должен целиком попадать во внешний объект второй карты. Если таковой объект не найден, выдается соответствующее предупреждение и открытая карта не закрывается для анализа ошибки.

;путь к карте - источнику копируемого параметра
$SourceMap=d:\test.dmf
;параметр, значение которого копируется
$SrcParam=ID20030
;параметр, в исходной карте принимающий значение
$DestParam=ID20030
$N=@Map.SelCount
@If $N<>1 @Break Выделите один объект
;запоминаем номер нашей карты
$ThisMap=@ActivateMap
;копируем помеченный объект в буфер
@Map.Copy
;открываем карту из которой хотим получить параметр
@FileOpen $SourceMap
;вставляем в открытую карту наш объект
@Map.Paste
;номер нашего объекта
$ThisObj=@Map.SelectedObject
;полигон, в который объект попал
$ParentObj=@Map.ParentObject $ThisObj
;не закрываем открытую карту, если не найден внешний объект
@if $ParentObj=$ThisObj then @Break Внешний полигон не найден
;копируем значение параметра внешнего объекта
$P=@Map.Object[$ParentObj].Parameter[$SrcParam]
;возвращаемся к исходной карте
@CloseMap
@ActivateMap $ThisMap
;вставляем скопированный параметр
$ThisObj=@Map.SelectedObject
@Map.Object[$ThisObj].Parameter[$DestParam] $P
;обновляем объект
@Map.RefreshObject $ThisObj

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 01 мар 2013 17:10 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Трансформирование сканированных планшетов топокарт с обрезкой зарамочного оформления

Скрипт выполняет трансформацию всех TIF растров из указанного каталога с заданными параметрами результирующего изображения. Результирующие орто записываются в указанный каталог и вставляются в виде ссылок на изображения в DMF файл. Исходные растры должны быть сориентированы по углам внутренней рамки. Результирующие орто не содержат изображение за областью внутренней рамки, расширенной на значение $ExpandValue (задается в метрах на местности).

$SourceDir=@Dialog.Ask Каталог исходных растров Default=d:\Images\Src
$DestDir=@Dialog.Ask Каталог результирующих растров Default=d:\Images\Dst
$MapScale=@Dialog.Ask Масштаб плaншетов Default=10000
;расширять рамки трапеций на указаное значение
$ExpandValue=@Dialog.Ask Расширять рамки трапеций на, м Default=50
;разрешение орто
$DPI=@Dialog.Ask DPI Default=200
;оттенки серого или цветное орто
$ColorChannels=@Dialog.Ask Цветовых каналов (1/3) Default=1
;создаем новую карту
@FileNew
;устанавливаем масштаб карты
@Map.SetProperties $MapScale Ortho
;вставляем растры в карту
@Map.InsertTriangulation $SourceDir\*.tif
$I=@Map.Count
@if $I=0 then @Break Растры в "$SourceDir" не найдены
;копируем рамки растров в буфер, они нам еще пригодятся
@Map.SelectAll
@Map.Copy
;расширяем рамки растров
@Map.Selected.ExpandPolygon $ExpandValue
;трансфоррмируем
@OrthoRectification $DPI $ColorChannels $DestDir
;запоминаем кол-во объектов карты
$RasterCount=@Map.Count
;разбиваем сложные полигоны изображений на внешние и внутренние рамки
[ Операции с объектами.Разделить ]
;удаляем внутренние рамки изображений
$I=@Map.Count
%Start1
@Map.DeleteObject $I
$I=$I-1
@if $I>$RasterCount then @Goto %Start1
@Map.DeselectAll
;вставляем исходные (не расширенные) рамки растров
@Map.Paste
;запоминаем слой добавленных объектов
$TriangLayer=@Map.Selected.Layer
;создаем сложный полигон
$I=$RasterCount
%Start2
@Map.DeselectAll
@Map.SelectObject $I
[ Операции с объектами.Сложный полигон ]
$I=$I-1
@if $I>0 then @Goto %Start2
;удаляем лишние объекты
@Map.Layers.Delete $TriangLayer
;сохраняем карту с ортофрагментами
@Map.SaveToFile


Если расширять внутренние рамки не требуется, тогда скрипт значительно упрощается.

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 06 мар 2013 09:17 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Расчет суммарной площади всех выделенных объектов карты

$N=@Map.SelCount
@if $N=0 then @Break Выделите объекты для которых требуется расчитать суммарную площадь
$SumArea=0
$N=0
%Start
$N=@Map.NextSelected $N
@if $N=0 then @Break Площадь выделенных объектов $SumArea
$Area=@Map.Object[$N].Parameter[0]
$SumArea=@Calc $SumArea+$Area
@Goto %Start


Единица измерения площади и формат вывода значения задаются маской параметра Площадь в Карта>Параметры. Чтобы скрипт работал правильно необходимо в Региональных настройках Windows установить разделить целой и дробной части - точка.

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 16 мар 2013 22:07 
Гуру
Гуру

Зарегистрирован:
06 июн 2010 06:35
Сообщения: 601
Откуда: Ліспроект
Знайти полігони з шарів зі стилем "тільки полігон" у статусі "правка", що частково/повністю накладаються на інші полігони того-ж шару, чи будь-яких шарів стилю "тільки полігон" у статусі "правка".

Наведений скрипт - спроба компенсувати відсутність функції [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


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 27 мар 2013 15:27 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Изменение указанного параметра для всех объектов заданного слоя во всех XML файлах в выбранной папке

Скрипт позволяет произвести массовую замену значения параметра на заданное значение во всех файлах в заданой папке. Список слоев и параметров загружается с указанного шаблона (в примере XMLNormal.dmf).

Если задан файл шаблона заполнения (csv), тогда значение параметра по умолчанию (оно высвечивается в диалоговом окне ввода значения) берется оттуда.

;шаблон для получения списка параметров
$UseTemplate=Templates\XMLNormal.dmf
;шаблон заполнения для получения значения параметра по умолчанию
$UseCSV=Templates\XML.csv
;искать файлы заданного типа
$Ext=.xml
$SourceDir=@Dialog.Ask Каталог исходных XML файлов Default=d:\Temp\Src
$DestDir=@Dialog.Ask Каталог результирующих XML файлов Default=d:\Temp\Dst
;открываем шаблон
@FileOpen $UseTemplate
;формируем список параметров шаблона
$Params=@Map.Parameters.List
$Layers=@Map.Layers.List
;закрываем шаблон
@FileClose
;выбираем слой в котором находятся интересующие объекты
$Layer=@Dialog.ListSelect Выберите слой|$Layers
$LayerId=@StringPart 1 $Layer
;выбираем параметр из списка параметров шаблона
$Param=@Dialog.ListSelect Выберите параметр|$Params
$ParamId=@StringPart 1 $Param
;
$ParamValue=
;из csv вытягиваем значение предлагаемое по умолчанию
$CSVFound=@FileExists $UseCSV
;csv шаблон не найден
@if $CSVFound=0 then @Goto %AskParamValue
@Text.Load $UseCSV
$N=@Text.Count
$I=1
$BlockFound=0
;в csv разделение колонок при помощи Tab
$Tab=@Calc Char(9)
$Tab=@DequoteText $Tab
;ищем строку вида -7 70005
;где -7 это номер параметра ID слоя
;70005 это значение параметра, то есть ID слоя
%CSVLoop
$S=@Text.Line[$I]
$P1=@StringPart 1$Tab$S
$P2=@StringPart 2$Tab$S
@if $P1= then @Goto %SkipRow
;убираем минус из -7 иначе Digitals сравнение рассматривает как арифм. выражение
$TempP1=@Calc Delete($P1,1,1)
;найден слой, соответствующий выбору пользователя
@if ($TempP1=7) and ($P2=$LayerId) then $BlockFound=1
@if ($BlockFound=0) or ($P1<>$ParamId) then @Goto %SkipRow
;найден параметр, соответствующий выбору пользователя
$N=@Calc Length($P1)
;удаляем первую часть строки - код параметра
$ParamValue=@Calc Delete("$S",1,$N+1)
;получаем значение параметра по умолчанию, считанное из csv
$ParamValue=@DequoteText $ParamValue
@Goto %AskParamValue
%SkipRow
$I=$I+1
@if $I<=$N then @Goto %CSVLoop
%AskParamValue
;
;значение параметра для заполнения в файлах
$Prompt=Введите значение параметра
@if $ParamValue= then @Goto %EnterParamValue
$Prompt=$Prompt|Значение по умолчанию взято из $UseCSV
%EnterParamValue
$ParamValue=@Dialog.Ask $Prompt Default=$ParamValue Size=450
;находим все файлы заданного типа в указанном каталоге
@Text.FolderList *$Ext $SourceDir
;проверяем или список пустой
$FileCount=@Text.Count
@If $FileCount=0 then @Break В папке "$SourceDir" отсутствуют файлы $Ext
;открываем файлы из списка по одному
$I=0
%MapLoop
$I=$I+1
@If $I>$FileCount then @Break
$F=@Text.Line[$I]
@FileOpen $F
;перебираем все объекты карты по одному
$ObjCount=@Map.Count
$J=0
%ObjLoop
$J=$J+1
@If $J>$ObjCount then @Goto %SaveMap
;пропускаем все объекты кроме нужного слоя
$ObjLayerId=@Map.Object[$J].LayerID
@if $ObjLayerId<>$LayerId then @Goto %ObjLoop
;меняем значение параметра объекта
@Map.Object[$J].Parameter[ID$ParamId]=$ParamValue
@Goto %ObjLoop
;сохраняем измененную карту
%SaveMap
$F=@Map.ClearShortFilename
@Map.SaveToFile $DestDir\$F$Ext
@FileClose
;переходим к следующей карте
@Goto %MapLoop

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 02 апр 2013 13:44 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Перемещение выделенного ортогонального прямоугольника к двум точкам сверху и слева от него

В карте выделяется прямоугольный объект, который требуется переместить и 2 точки слева и сверху от объекта. После выполнения скрипта прямоугольник смещается по осям X и Y, так что точки оказываются на его верхней и левой сторонах. Разделитель целой и дробной частей числа обязательно должен быть точка. Смотрите пример во вложении.

$C=@Map.SelCount
@If $C<>3 @Break Нужно пометить прямоугольник и 2 точки, к которым требуется переместить прямоугольник
;
;получаем индексы прямоугольника и 2-х точек
$N=1
$Rect=0
$Pnt1=0
$Pnt2=0
%Start1
$C=@Map.Object[$N].Count
@If ($C=5) and ($Rect=0) then $Rect=$N
@If ($C=1) and ($Pnt1=0) then $Pnt1=$N
@If ($C=1) and ($Pnt2=0) and ($Pnt1<>$N) then $Pnt2=$N
$N=@Map.NextSelected $N
@If $N>0 @Goto %Start1
@If ($Rect=0) or ($Pnt1=0) or ($Pnt2=0) then @Break Среди помеченных не найдены прямоугольник либо точки
;
;находим верхнюю и левую границы прямоугольника
;в карте не должно быть отрицательных координат!
$Top=0
$Left=10000000
$N=1
%Start2
$P=@Map.Object[$Rect].Point[$N]
$X=@StringPart 1 $P
$Y=@StringPart 2 $P
@If $X>$Top then $Top=$X
@If $Y<$Left then $Left=$Y
$N=$N+1
@If $N<5 @Goto %Start2
;
;определяем какая точка выше
$P1=@Map.Object[$Pnt1].Point[1]
$X1=@StringPart 1 $P1
$Y1=@StringPart 2 $P1
$P2=@Map.Object[$Pnt2].Point[1]
$X2=@StringPart 1 $P2
$Y2=@StringPart 2 $P2
;
;находим векторы перемещения прямоугольника по X и по Y
;если первая точка выше
@If $X1>=$X2 then $VX=$X1-$Top
@If $X1>=$X2 then $VY=$Left-$Y2
;если вторая точка выше
@If $X1<$X2 then $VX=$X2-$Top
@If $X1<$X2 then $VY=$Left-$Y1
;
;перемещаем прямоугольник
@Map.Undo.StartOperationGroup
$N=1
%Start3
$P=@Map.Object[$Rect].Point[$N]
$X=@StringPart 1 $P
$Y=@StringPart 2 $P
$Z=@StringPart 3 $P
$X=$X+$VX
$Y=$Y-$VY
@Map.Object[$Rect].Point[$N] $X $Y $Z
$N=$N+1
@If $N<=5 @Goto %Start3
@Map.RefreshObject $Rect
@Window.Refresh


Вложения:
MoveRectangle.dmf [697 байт]
Скачиваний: 321

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 08 апр 2013 15:05 
Гуру
Гуру

Зарегистрирован:
18 апр 2007 11:55
Сообщения: 1863
Откуда: Vinnitsa
Заполнение параметра ID7001004 "Додаткова інформація" смежника в XML-файле, строками вида "від ... до ... - <название смежника>".
Важно чтобы смежники в карте были в порядке возрастания "первой буквы". При открытии ранее сохраненного (версиями после 03.2013) XML-файла этот порядок достигается.

;счетчик для смежников
$I=0
;букаффки
$Letters=АБВГДЄЕЖЗІИЙКЛМНОПРСТУФХватит
;кол-во объектов в карте
$CN=@Map.Count
;кол-во объектов в слое XML_Суміжник
$AC=@Map.Layers.ObjectCount ID70010
;счетчик для смежников
$CC=0
;начало цикла
%Loop
;номер следующего объекта
$I=$I+1
;находим ID слоя текущего объекта
$LID=@Map.Object[$I].LayerID
;если не смежник, то идем дальше
@if $LID<>70010 then @Goto %Continue
;найден новый смежник
$CC=$CC+1
;первая буква
$FirstLetter=@Calc Copy("$Letters",$CC,1)
$FirstLetter=@DequoteText $FirstLetter
;вторая буква
$SecondLetter=@Calc Copy("$Letters",$CC+1,1)
;если последний смежник, то буква "А"
@if $CC=$AC then $SecondLetter=@Calc Copy("$Letters",1,1)
$SecondLetter=@DequoteText $SecondLetter
;получить название смежника используя формулу XMP(значение по умолчанию)
$S=@Map.Object[$I].CalculateFormula XMP(Землі загального користування)
;присвоить значение параметру ID7001004
@Map.Object[$I].Parameter[ID7001004] <AdditionalInfoBlock><AdditionalInfo>від $FirstLetter до $SecondLetter - $S</AdditionalInfo></AdditionalInfoBlock>
;продолжаем для каждого объекта в карте
%Continue
@if $I<$CN then @Goto %Loop

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 18 апр 2013 14:34 
Гуру
Гуру

Зарегистрирован:
18 апр 2007 11:55
Сообщения: 1863
Откуда: Vinnitsa
Извлечение в In4 всех участков в карте

Скрипт извлекает в In4 все участки и записывает в рабочую папку(Сервис-Настройки-Главная-Рабочая папка по умолчанию). Удобен при большом кол-ве участков в карте тем что, в отличии от команды "Извлечь в ин4...", закрывает за собой окна и следит за дубляжем имен файлов.

$Source=@ActivateMap
@Map.DeselectAll
$Count=@Map.Count
$CurrentObject=0
%Loop
$CurrentObject=$CurrentObject+1
$LID=@Map.Object[$CurrentObject].LayerID
@if $LID<>20000 then @Goto %Continue
@Map.SelectObject $CurrentObject
Файл | Извлечь участок в In4
$Target=@ActivateMap
$CurrObj=@Map.SelectedObject
$FName=@Map.ClearFilename
$Suffix=0
%NextSuffix
$Suffix=$Suffix+1
$FFN=$FName
@if $Suffix<>1 then $FFN=$FFN($Suffix)
$FFN=$FFN.in4
$FE=@FileExists $FFN
@if $FE<>0 then @Goto %NextSuffix
%SaveIn4
@Map.SaveToFile $FFN
@CloseMap $Target
%Continue
@ActivateMap $Source
@Map.DeselectAll
@if $CurrentObject<$Count then @Goto %Loop

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 25 апр 2013 10:45 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Вырезание объектов карты внутри заданных полигонов

Скрипт получает от пользователя слой в котором находятся полигоны, по которым выполняется обрезка. Далее перебирает эти полигоны по одному и обрезает все объекты за пределами режущего полигона. Результат копируется в новую карту. Полигоны, по которым выполняется обрезка не должны быть сложными полигонами.

;выбираем слой с полигонами по которым выполняется обрезка
$Layers=@Map.Layers.List
$Layer=@Dialog.ListSelect Выберите слой с полигонами|$Layers
$LayerId=@StringPart 1 $Layer
;запоминаем номер нашей карты
$ThisMap=@ActivateMap
;создаем чистую карту без шаблона
popTemplate | <Чистый>
;запоминаем ее номер
$NewMap=@ActivateMap
;переключаемся в исходную карту
@ActivateMap $ThisMap
;цикл по объектам заданного слоя
$I=@Map.Count
%Start
$ObjLayerId=@Map.Object[$I].LayerId
@if $ObjLayerId<>$LayerId then Goto %Continue
;выделяем полигон
@Map.DeselectAll
@Map.SelectObject $I
;обрезаем все объекты за пределами полигона
Сервис | Обрезать по полигону/рамке
;копируем все объекты в буфер
@Map.SelectAll
@Map.Copy
;активируем результирующую карту
@ActivateMap $NewMap
;вставляем объекты
@Map.Paste
;возвращаемся в исходную карту
@ActivateMap $ThisMap
;отменяем обрезку
@Map.Undo.Undo
%Continue
$I=$I-1
@if $I>1 then Goto %Start
;переключаемся в результирующую карту
@ActivateMap $NewMap
@Map.DeselectAll
Вид | Показать все

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 05 июн 2013 11:53 
Участник
Участник

Зарегистрирован:
05 июн 2013 10:32
Сообщения: 2
добавил этот скрипт и открыл ІКК но он там нече не ищет,пишет участок не найден


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 07 авг 2013 08:40 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Laroc писал(а):
добавил этот скрипт и открыл ІКК но он там нече не ищет,пишет участок не найден

Нужен пример вашей ИКК.

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 07 авг 2013 08:45 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Подписывание высот точек объектов

Скрипт обрабатывает событие добавление точечного объекта, находит ближайший к добавленному объект карты и его ближайшую точку. Создает таблицу со значением высоты найденной ближайшей точки.

%Events.OnCollect
;задайте здесь ID для слоя таблиц с подписями высоты
$TableLayerID=ID1
$TableLayer=@Map.Layers.FindByID $TableLayerID
@if $TableLayer=0 then @Break Layer with $TableLayerID not found
;номер только что собранного объекта
$N=@EventObject
;берем первую точку этого объекта
$P=@Map.Object[$N].Point[1]
;ищем ближайший к этой точке объект
$FoundObj=@Map.NearestObject 50 $N $P
@if $FoundObj=0 then @Break Nearest object not found
;удаляем только что собранный объект
@Map.DeleteObject $N
;ищем ближайшую точку в ближайшем объекте
$FoundPnt=@Map.NearestPoint $FoundObj 0 $P
;берем ее координаты
$P2=@Map.Object[$FoundObj].Point[$FoundPnt]
;выделяем Z координату
$Z=@StringPart 3 $P2
;создаем таблицу с подписью высоты
$TableObj=@Map.NewObject $TableLayer
@Map.Object[$TableObj].Point[1] $P
@Map.Object[$TableObj].TableText $Z
@Map.RefreshObject $TableObj


Вложения:
LabelingZValues.exe [337.22 Кб]
Скачиваний: 335

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 09 авг 2013 08:00 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Групповая обработка файлов в указанной папке. Выполнение команды совмещения точек.

$Ext=*.dmf
$SourceDir=@Dialog.SelectFolder Каталог исходных файлов
$DestDir=@Dialog.SelectFolder Каталог результирующих файлов
@Text.FolderList $Ext $SourceDir
$C=@Text.Count
@If $C=0 @Break В папке "$SourceDir" файлы $Ext не найдены
%Start
$FileName=@Text.Line[$C]
@FileOpen $FileName
@Map.SelectAll
Правка | Совместить с соседними
$FileName=@ExtractFileName $FileName
@Map.SaveToFile $DestDir\$FileName
@FileClose
$C=$C-1
@if $C>0 then @Goto %Start


Команды обработки выделены в скрипте жирным и могут быть заменены любыми другими командами.

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 09 авг 2013 08:38 
Гуру
Гуру

Зарегистрирован:
26 фев 2007 12:04
Сообщения: 1751
Откуда: Vinnitsa
Перевод в верхний регистр букв в значении заданного параметра во всех объектах карты.

$ParamNumber=1
$C=@Map.Count
@if $C=0 then @Break
%Start
$S=@Map.Object[$C].Parameter[$ParamNumber]
$S=@UpperCase $S
@Map.Object[$C].Parameter[$ParamNumber] $S
@Map.RefreshObject $C
$C=$C-1
@Window.Refresh

_________________
Команда разработчиков Digitals
(наш e-mail и ICQ находятся в меню Помощь|О программе)
Новичкам сюда | Новые возможности программы | Купить Digitals


Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Библиотека полезных скриптов
СообщениеДобавлено: 09 авг 2013 10:12 
Гуру
Гуру

Зарегистрирован:
06 июн 2010 06:35
Сообщения: 601
Откуда: Ліспроект
Приведення шарів карти в плановість згідно переліку назв шарів у текстовому файлі \Digitals\Templates\PlanLay.txt.

Список назв шарів має бути сортований в порядку бажаного розміщення їх (від нижнього плану до верхнього).

$MapExist=@MapCount
@If $MapExist=0 then @Break Відкрийте карту для приведення її до порядку плановості шарів
$FilFold=@ProgramPath
$FilFold=$FilFold\Templates\PlanLay.txt
$ExistFile=@FileExists $FilFold
@If $ExistFile=0 then @Break Не знайдено довідника плановості шарів||Відсутній файл $FilFold
$Worker=@Dialog.Confirm Скрипт виконає приведення карти до порядку плановості шарів|згідно файла $FilFold||Продовжити?
@If $Worker=0 @Break
@Map.BeginUpdate
@Map.DeselectAll
@Text[1].Load $FilFold
$CountLinText=@Text[1].Count
$NLin=1
%StartLine
$Lay=@Text[1].Line[$NLin]
@Map.FindByParameters 1|-5=$Lay
@Map.Selected.BringToFront
$NLin=$NLin+1
@If $NLin<=$CountLinText @Goto %StartLine
@Map.CancelUpdate
@Map.DeselectAll
@Map.CalculateRange
@Window.Refresh


Последний раз редактировалось voha 27 авг 2013 15:54, всего редактировалось 1 раз.

Вернуться к началу
 Профиль Отправить email  
 
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 161 ]  На страницу Пред.  1, 2, 3, 4, 5 ... 11  След.

Часовой пояс: UTC + 2 часа


Кто сейчас на конференции

Сейчас этот форум просматривают: Google [Bot], Rostyslav и гости: 6


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
Русская поддержка phpBB