MB60UG

Приложение B: Текст программы TEXTBOX

Программа TEXTBOX и ее фрагменты используются в этом Руководстве в качестве

примеров. Ниже приводится полный текст этой программы.

'********************************************************************

'Программа MapBasic: TEXTBOX.MB

'Эта программа рисует рамку вокруг выбранного текста

'в виде прямоугольника или сглаженного прямоугольника.

'Работает она следующим образом:

'(1) пользователь создает один или несколько текстовых объектов

'в окне Карты или Отчета,

'(2) затем пользователь выбирает один или несколько текстовых

'(3) объектов, затем выбирает один или несколько текстовых

'	объектов, выбирает в диалоге цвета, формы и др. атрибуты рамки
'	После нажатия на кнопку OK программа рисует рамки
'	вокруг всех выбранных текстовых объектов.
' ЗАМЕЧАНИЕ:Текстовые объекты должны находиться на изменяемом слое
'	Карты, на изменяемом Косметическом слое или в окне Отчета.
'	Слой Карты не должен быть открыт только для чтения.
'

'В программе иллюстрируется использование следующих

'операторов и процедур MapBasic:

'Create Menu, Alter Menu Item

'Dialog

'SelectionInfo()

'ObjectGeography()

'ObjectInfo()

'Alter Object

'Update

'ProgressBar

'OnError

'Использование функций из библиотеки AUTO_LIB позволяет программе

'устанавливать себя в стартовый Рабочий Набор MapInfo.

'

Приложение B: Текст программы TEXTBOX

'*********************************************************************

'	Объявления sub-процедур

Declare Sub Main

Declare Sub About

Declare Sub create_sub

Declare Sub next_box

Declare Sub Bye

'*********************************************************************

'	Include-файлы и стандартные определения

'

Include "mapbasic.def" 'стандартные определения

Include "auto_lib.def" 'доступ к библиотеке AUTO_LIB, текст которой 'находится в файле AUTO_LIB.MB

'*********************************************************************

' Объявления глобальных переменных

Global on_layout As Logical Global table_name As String Global pstyle As Pen Global bstyle As Brush

Global box_type, num_rows, next_row, num_drawn As Integer

Global reset_color As Logical		'TRUE=сменить цвет текста на цвет рамки
Global line_color As Integer		'RGB-цвет рамки
Global shift_ok As	SmallInt	'Сдвиг кнопки "OK" вправо
Global shift_cancel	As SmallInt	'Сдвиг кнопки "Отмена" вправо

'*********************************************************************

'Основная процедура: Main

'В процедуре Main добавляется меню в строку меню,

'Затем пользователь выбирает одну из команд

'

'*********************************************************************

Sub Main

' Присвоение переменных, используемых при организации самозагрузки

gsAppFilename = "textbox.mbx" ' название файла с текстом программы gsAppDescription = """Рамка""" ' Название MB-программы

If SystemInfo(SYS_INFO_PLATFORM) = PLATFORM_MAC Then

shift_ok = 45 'В среде Macintosh расположить 'кнопки по-другому

shift_cancel = 0

Else

shift_ok = 0

shift_cancel = 45 'В среде Windows поместить кнопку '"Отмена" справа от "OK"

256

Приложение B: Текст программы TEXTBOX

End If

Create Menu "Рамка" As

"&Создать рамки..." Calling create_sub,

"Â&ûõîä" Calling Bye,
"&О программе ""Рамка""..."			Calling About
Alter Menu "Программы" Add
"(-",
"Рамка" As "Рамка"
Alter Menu Bar Remove ID 6, ID 7
Alter Menu Bar Add "Программы", ID 6, ID 7
Menu Bar Show		' показать новый вариант строки меню
pstyle = MakePen(1, 2, BLACK)		' создать стандартный стиль линии
bstyle = MakeBrush(1, 0, 0)		' создать пустое заполнение
box_type = 1	' стандартные прямоугольники - несглаженные
reset_color = FALSE	' Стандартный режим - не менять цвет текста

End Sub

'*********************************************************************

'Sub-процедура: About

'Вызывается командой Рамка > О программе "Рамка"

'Демонстрирует диалог с объяснениями.

'*********************************************************************

Sub About

Dialog

Title "О программе ""Рамка""" Control StaticText

Title "Эта программа рисует декоративные рамки вокруг" Position 10, 10

Control StaticText

Title "текстовых объектов в окне Карты или Отчета." Position 10, 18

Control StaticText

Title "Выберите сначала один или несколько" Position 10, 40

Control StaticText

Title "текстовых объектов, затем выполните команду" Position 10, 48

Control StaticText

Title """Создать Рамки"" из меню ""Рамка""." Position 10, 56

Control StaticText

Title "Внимание: Программа ""Рамка"" не поддерживает" Position 10, 80

Control StaticText

Title "непроецированные карты (планы)." Position 10, 88

Control Button

Title "Самозапуск..." Calling HandleInstallation Width 80

257

Приложение B: Текст программы TEXTBOX

Position 30, 110

Control OKButton

Title "OK"

Position 130, 110

'Внимание: Нажатие на кнопку ""Самозапуск"" вызывает процедуру

'HandleInstallation() из библиотеки AUTO_LIB. Эта процедура

'открывает диалог, в котором пользователь может сделать так,

'чтобы "Рамка" загружалась автоматически при старте MapInfo.

End Sub

'*********************************************************************

'Sub-процедура create_sub

'Вызывается командой Программы > Рамка > Создать рамки.

'Эта процедура показывает диалог, в котором пользователь

'устанавливает разные режимы.

'*********************************************************************

Sub create_sub

' Объявление локальных переменных

Dim i As SmallInt, text_objs As Logical

Dim destination_table As String

'Если ничего не выбрано или если выбрана запись в таблице,

'не имеющая графического объекта, то предлагается сделать выбор.

num_rows = SelectionInfo(SEL_INFO_NROWS) If num_rows > 0 Then

table_name = SelectionInfo(SEL_INFO_TABLENAME)

If TableInfo(table_name, TAB_INFO_MAPPABLE) = FALSE Then Note "Выберите один или несколько текстовых" + Chr$(13)

+ "объектов перед рисованием рамок." Exit Sub

End If

Else

'(если количество выбранных записей равно нулю) Note "Нужно выбрать один или несколько текстовых "

+Chr$(13) + " объектов перед рисованием рамок." Exit Sub

End If

'Теперь нужно затратить время на определение того, какие из выбранных

'объектов являются текстовыми (в выборке их может не быть вообще).

'Если в выборке нет текстовых объектов, выдается сообщение пользователю.

'

'Пользователь может также выбрать очень много объектов, и проверка может

'затянуться. Поэтому проверяются первые 20 и, если среди них нет

'текстовых объектов,выдается сообщение пользователю.

258

Приложение B: Текст программы TEXTBOX

i = 1

text_objs = FALSE

Do While i <= num_rows

Fetch Rec i From Selection

If Str$(Selection.obj) = "Text" Or i > 20 Then text_objs = TRUE

Exit Do End If

i = i + 1

Loop

If Not text_objs Then

Note "Нужно выбрать один или несколько текстовых " + Chr$(13) + "объектов перед рисованием рамок."

Exit Sub

End If

'Определить, где мы находимся: в Отчете или в Карте

'и установить различающую переменную.

on_layout = FALSE

If TableInfo(table_name, TAB_INFO_TEMP) = TRUE And Left$(table_name, 6) = "Layout" Then

on_layout = TRUE Else

'Если это не Отчет, проверить, не открыта ли таблица

'в режиме "только-для-чтения". Если это так, выйти. If TableInfo(table_name, TAB_INFO_READONLY) Then

Note "Вы выбрали объекты из таблицы," + Chr$(13) + "открытой только для чтения." + Chr$(13) + Chr$(13) +

"Откройте таблицу " + table_name + " в обычном режиме " + "или выберите объекты из другой таблицы."

Exit Sub End If

End If

If on_layout Then

destination_table = "в окно Отчета"

ElseIf InStr(1, table_name, "Cosmetic") > 0 Then destination_table = "на Косметический слой окна Карты"

Else

destination_table = "в таблицу " + table_name

End If
Dialog	Title "Создание рамок"

Control StaticText

Title "Создать рамки вокруг выбранных текстов"

Position 15, 5

Control GroupBox

Title "Форма рамки:"

Position 10,20

Width 160 Height 40

Control RadioGroup

Title "&Прямоугольник;&Сглаженный прямоугольник"

Position 20,32

Value box_type

Into box_type

Control StaticText

259

Приложение B: Текст программы TEXTBOX

Title "Стиль линии:"

Position 20,70

Control PenPicker

Value pstyle

Into pstyle

Position 70,70

Width	20	Height 20
Control	GroupBox
Title "Рамки будут помещены:"
Position 10,100
Width	160	Height 40
Control	StaticText

Title destination_table Position 20,120

Control CheckBox

Title "Сделать одинаковыми цвета текста и рамки" Position 10, 150

Value reset_color Into reset_color

Control OKButton

Title "OK"

Position 90 + shift_ok, 180 Control CancelButton

Title "Отмена"

Position 90 + shift_cancel, 180

'Диалог определен. Нажатие на кнопку "Отмена" заканчивает работу. If Not CommandInfo(CMD_INFO_DLG_OK) Then

Exit Sub End If

line_color = StyleAttr(pstyle, PEN_COLOR)

num_drawn = 0 ' инициализация счетчика нарисованных рамок next_row = 1 ' следующая обрабатываемая запись

'В окне Отчета перед работой с объектами

'нужно выполнить оператор Set CoordSys If on_layout Then

Set CoordSys Layout Units "mm" Else

Set CoordSys Earth End If

'Далее используется шкала выполнения (диалог "Минуточку").

'Оператор ProgressBar последовательно вызывает процедуру NEXTBOX,

'пока не будут сделаны все работы или пока не будет нажата кнопка "Отмена".

ProgressBar "Создание рамок вокруг текстов..." Calling next_box Range num_rows

If CommandInfo(CMD_INFO_DLG_OK) Then

Note "Процесс завершен. " + Chr$(13) + Chr$(13) + "Создано рамок: " + Str$(num_drawn)

Else

Note "Процесс прерван! " + Chr$(13) + Chr$(13) + "Создано рамок: " + Str$(num_drawn)

End If Exit Sub

End Sub

260

Приложение B: Текст программы TEXTBOX

'*****************************************************************' Subпроцедура: next_box

'

'Процедура next_box рисует одну рамку вокруг одного текста.

'Оператор ProgressBar (выше) вызывает эту процедуру

'до тех пор, пока процесс не завершится или не прервется '*****************************************************************Sub next_box

'Declare local variables Dim objcopy, tbox As Object Dim oldfont, newfont As Font

Dim center_x, center_y, dx, dy, radius, x1, y1, x2, y2 As Float

'Переход к следующему объекту из выборки

Fetch Rec next_row From Selection

' Рамка рисуется только вокруг текстовых объектов If Str$(Selection.obj) = "Text" Then

' Определение размеров текстового объекта objcopy = Selection.obj

x1 = ObjectGeography(objcopy, OBJ_GEO_MINX)

x2 = ObjectGeography(objcopy, OBJ_GEO_MAXX)

y1 = ObjectGeography(objcopy, OBJ_GEO_MINY)

y2 = ObjectGeography(objcopy, OBJ_GEO_MAXY) center_x = (x1 + x2) / 2

center_y = (y1 + y2) / 2 dx = Abs(x2 - x1) / 2 dy = Abs(y2 - y1) / 2

dx = dx + .3 * Minimum(dx, dy) dy = dy + .3 * Minimum(dx, dy) x1 = center_x - dx

x2 = center_x + dx

y1 = center_y - dy

y2 = center_y + dy If box_type = 1 Then

Create Rect

Into Variable tbox (x1, y1) (x2, y2)

Pen pstyle Brush bstyle

Else

' Вычисление радиуса закруглений для углов сглаженной рамки radius = .6 * Minimum(dx, dy)

Create RoundRect

Into Variable tbox

261

Приложение B: Текст программы TEXTBOX

(x1, y1) (x2, y2) radius Pen pstyle Brush bstyle

End If

Insert Into table_name (obj) Values (tbox) num_drawn = num_drawn + 1

If reset_color Then

'...далее, поскольку пользователь установил флажок

'"Сделать одинаковыми цвета рамки и текста",

'производятся следующие действия:

'сначала считывается стиль шрифта текстового объекта,...

'

oldfont = ObjectInfo(objcopy, OBJ_INFO_TEXTFONT)

'

' затем создается новый стиль с новым цветом,...

newfont = MakeFont( StyleAttr(oldfont, FONT_NAME), StyleAttr(oldfont, FONT_STYLE), Maximum(StyleAttr(oldfont, FONT_POINTSIZE), 1), line_color,

StyleAttr(oldfont, FONT_BACKCOLOR) )

'

'затем новый стиль назначается переменной Object...

'Alter Object objcopy Info OBJ_INFO_TXTFONT,newfont

'Наконец, записываем изменный объект в таблицу

'

Update Selection Set Obj= objcopy Where RowID=next_row

End IF
End If
If next_row >= num_rows Then	'Если считана последняя запись
ProgressBar = -1	'сигнал: процесс завершен
Else
ProgressBar = next_row	'сигнал: процесс продолжается
End If
next_row = next_row + 1

End Sub

'**************************************************************************

'Sub procedure: Bye

'Вызывается командой Рамка > Выход.

'Закрывает программу. '************************************************************************** Sub Bye

262

Приложение B: Текст программы TEXTBOX

End Program
End Sub
'///////////	Конец программы TEXTBOX.MB	////////////

263