Код: Выделить всё
Include "mapbasic.def"
Define DEFRAD 1000 ' радиус в метрах по умолчанию
Declare Sub Main
Declare Sub ExitApp
Declare Sub MkCirc
Sub Main
Create Menu "Круги" As
"Создать круги" Calling MkCirc,
"(-",
"Выйти" Calling ExitApp
Alter Menu ID 4 Add "Круги" As "Круги"
End Sub
Sub ExitApp
End Program
End Sub
Sub MkCirc
Dim sel, tbl, fname As String
Dim sel_col1, sel_cobj As Alias
Dim sel_obj As Object
Dim r As Float
If SelectionInfo(SEL_INFO_NROWS) = 0 Then
Note "Выберите объект(ы) в окне ""Карта"""
Exit Sub
End If
If WindowInfo(FrontWindow(), WIN_INFO_TYPE) <> WIN_MAPPER Then
Note "Выберите объект(ы) в окне ""Карта"""
Exit Sub
End If
Set CoordSys Window FrontWindow()
' Set Map Distance Units "m" / Странно, но не работает. Придётся переводить метры в статутные мили.
fname = FileSaveAsDlg(GetFolderPath$(FOLDER_MYDOCS) + "\", "", "tab", "Создать таблицу")
If fname = "" Then
Exit Sub
End If
tbl = PathToTableName$(fname)
sel = SelectionInfo(SEL_INFO_SELNAME)
sel_col1 = sel + ".Col1"
sel_cobj = sel + ".Obj"
Create Table tbl ("Radius" Float)
Create Map For tbl CoordSys Window FrontWindow()
Fetch First From sel
Do Until EOT(sel)
sel_obj = sel_cobj
Do Case ColumnInfo(sel, "COL1", COL_INFO_TYPE)
Case COL_TYPE_DECIMAL, COL_TYPE_INTEGER, COL_TYPE_SMALLINT, COL_TYPE_FLOAT
r = sel_col1
Case Else
r = DEFRAD
End Case
Insert Into tbl (Radius, Obj) Values (r, CreateCircle(CentroidX(sel_obj), CentroidY(sel_obj), r / 1609.344))
Fetch Next From sel
Loop
Close Table sel
Commit Table tbl
Add Map Layer tbl
End Sub- выделить один или несколько объектов в окне карты;
- в меню нажать "Создать круги";
- выбрать папку и имя файла со слоем кругов;
- созерцать круги в окне карты.
Один нюанс. Вопреки тому, что говорится в документации, команда Set Map Distance Units "m" у меня не сработала. Пришлось пересчитывать радиусы в статутные мили.