Отправляет email-рассылки с помощью сервиса Sendsay
  Все выпуски  

ГИС: обсуждаем, изучаем, делимся.


ГИС: обсуждаем, изучаем, делимся.

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

Каким-то образом у Вас появились два слоя: полигоны и их центроидов- точек. Атрибутика находится в точечных объектах. Достаточно неудобно. Во-первых приходится хранить два слоя, во вторых неудобно отображать информацию. Например, разокрасить полигоны в зависимости от значений.

Итак задача:

1)необходимо каждому полигону сопоставить точечный объект с атрибутивной информацией, т.е. записать уникальный номер точки в таблицу полигона. В моём случае это было поля Name. две таблицы pk-с точечными объектами и gk- полигоны.

2) в случае если точки сдвинулись по каким-то причинам: вышли за пределы полигона, уточнить. Т.е. если на территории одного полигона находятся не одна точка, то подкорректировать. Такие полигоны, к котрым добавить атрибутику автоматически не удалось, выделяются красным цветом. Для этого в меню "MY" создаются две команды "Select poly" и "Add info", которые работают следующим образом: Вы Выбираете красный полигон, нажимаете "Select poly"(ctrl+1) затем выбираете соответствующий ему точечный объект, нажимаете "ADD Info" (ctrl+2). Значение колонки Name таблицы pk записывается в соответствующее поле Name таблицы gk.

Я эту задачку решал на MapBasic.

Ниже приводится пример скрипта. Т.к. скрипт я писал для себя то не делал проверки, "защиту от дурака".

Include "mapbasic.def" 'включаем стандартные переменные

Declare Sub FromPkToGk

Declare Sub DrawMap

Declare Sub Create_Menu

Declare Sub Select_Button_On

Declare Sub Point_Button_On

Declare Sub myExit

Declare Sub main

'=====================================

Sub FromPkToGk 'автоматическое сопоставление полигонов и точек

Dim oPk, oGk as Object

Dim nRow as Integer

Dim sPop as String

Dim iUser_Id, iName as Integer

'здесь путь к вашим таблицам. Можно использовать

'ApplicationDirectory$()+"\file_name", тогда таблицы и макрос должны быть

' в одной папке

open table "d:\work\test\pk" as pk

open table "d:\work\test\gk" as gk

Fetch first from gk

nRow=1

Do While Not EOT(gk)

Select * from Gk Where RowID = nRow Into tCurGk

oGk=tCurGk.obj

Select * From pk Where obj within oGk Into Work_Table

'проверка чтобы каждой точке соответствовал один полигон

If TableInfo("Work_Table",TAB_INFO_NROWS)=1 Then

iName= Work_Table.Name

update tCurGk

Set Name=iName

End If

nRow=nRow+1

Fetch Next From gk

Loop

End Sub

'==================================Exit========

Sub myExit 'закончить работу программы

End Program

End Sub

'================================== Menu и комбинации клавиш

Sub Create_Menu

Create Menu "MY" As

"SELECT_POLY" + Chr$(9) + "CTRL+1/W^%49" Calling Select_Button_On,

"ADD Info From POINT" + Chr$(9) + "CTRL+2/W^%50"Calling Point_Button_On,

"(-",

"Exit" Calling myExit

Alter Menu Bar Add "MY"

End sub

'=============== Выбираем полигон и запоминаем в таблицу tWork

Sub Select_Button_On

select * From Selection Into tWork

End Sub

'=============================сопоставляем полигону точечный объект

Sub Point_Button_On

Dim iName as Integer

select * From Selection Into tPoint

iName=tPoint.Name

update tWork

Set Name=iName

commit table tWork

Select * From gk Where Name=0 Into tWork

set map redraw off

Add Map Layer tWork Set Map Order 2,1,3

'когда Вам лень думать как делать, иногда помогает окно MapBasic в котором

'отображаются выполняемые команды. Берёте их и копируете. Так, например, я

'получил следующую строку. И ведь работает!!! :)

Set Map Layer 2 Display Global Zoom (0, 100000) Units "m" Off Editable Off Selectable On Global Line (1,2,0) Global Pen (1,2,0) Global Brush (2,16732240,16777215) Global Symbol (35,0,12) Global Font ("Arial Cyr",0,9,0) Label Line None Position Center Font ("Arial Cyr",0,9,0) Pen (1,2,0) With USER_ID Parallel On Auto Off Overlap Off PartialSegments Off Duplicates On Offset 2 Max Visibility On Nodes Off Arrows Off Centroids Off

set map redraw on

End Sub

'==================

Sub DrawMap 'находим все безымянные полигоны и разокрашиваем их красным цветом

Select * From gk Where Name=0 Into tWork

Map From pk, tWork, gk max

Set Map Layer 2 Display Global Global Brush (2,16732240,16777215)

set map redraw on

End Sub

'===========================================Main=====

Sub main 'главная процедура, которая выполняется при запуске.

call Create_Menu

call FromPkToGk

Call DrawMap

End Sub

'======================КОНЕЦ==========================

Возможно, если у Вас будет похожая задача, то придётся параллельно выполнить:

замыкание полилиний, создание полигонов из полилиний, редактирование таблиц, …

Если будет кому-то это интересно- напишу, но всё это есть в хелпе.

С уважением.

Дмитрий Суворов.

sdm98"собачка"mail.ru


В избранное