Скрипты VBA в CorelDRAW

Источник: bzhome

Boris Zulin

Начиная с версии 9.0, CorelDRAW поддерживает скрипты VBA (лицензировано у Microsoft). Программисты, знакомые с VBA по пакету MS Office без проблем смогут приступить к программированию и в CorelDRAW.

Рассмотрим примеры написания полезных в дизайне программ и разберём механизм их работы. В качестве иллюстрации будем использовать последнюю на момент обновления статью версию Corel Draw 12. Для удобства использования создадим новый модуль макросов. В папке "C:\Program Files\Corel\Corel Graphics 12\Draw\GMS\" создайте пустой файл с именем cdrTools.gms [3]. Загрузите Corel Draw, вызовите редактор VBA командой Tools/Visual Basic/Visual Basic editor... (Alt+F11). В окне Projects выберите GlobalMacros (cdrTools.gms), в окне свойств или с помощью контекстной команды Properties задайте имя проекта Tools. В контекстном меню командой Insert/Module создайте область записи кода. Теперь приступим к написанию кода. При необходимости раскройте окно редактора для удобства работы. Процедуры ниже чередуются с описанием. Скопируйте текст подпрограмм в редактор и сохраните командой File/Save (Ctrl+S). Хочу обратить ваше внимание, что в Windows 2000/XP модуль можно сохранить в профиль пользователя (C:\Documents and Settings\имя\Application Data\Corel\Graphics12\User Draw\GMS\), из-за чего этот модуль будет доступен только данному пользователю и пользователь сможет этот модуль изменять. Модули, размещенные в папке Program Files доступны для редактирования по умолчанию только для администраторов и опытных пользователей.

Первая строка модуля с оператором Option Explicit определяет явное описание всех переменных, что позволяет уменьшить количество ошибок. Подпрограмма DistributeButt используется для размещения выделенных объектов встык (горизонтально или вертикально). Ранее для позиционирования использовался следующий метод: создавалась дополнительная линия (горизонтальная или вертикальная), выравнивалась с первым объектом по правому краю, а другой объект выравнивался с ней по левому. Затем линия уничтожалась. Подпрограмма перебирает все объекты, которые были выделены, начиная с последнего выделенного (соблюдается концепция CorelDRAW изменения свойств по последнему выделенному объекту), устанавливая позицию каждого следующего как позиция предыдущего плюс размер предыдущего объекта. Для вызова с помощью кнопок на панелях инструментов или с помощью меню создаём две дополнительные подпрограммы - DistributeButtVertical и DistributeButtHorizontal. Обращаю ваше внимание, что в VBA описание типа в операторе DIM производится для каждой переменной. Для эффективной работы применяется цикл For Each ... In ... : Next, который перебирает все указанные объекты. В основной процедуре в строках 12-17 описываем переменные и их типы, далее определяем количество выделенных объектов и прерываем процедуру с сообщением о невозможности выполнения, если выделено менее двух объектов. В строке 24 задаём начало группы команд, группа определяется как одно действие для команд отмены/повтора и её название выводится в списке отмены действий. Далее, перебирая в цикле выделенные объекты устанавливаем координаты начала каждого следующего объекта равной координате конца предыдущего.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
31
32
33
34
35
36
37
38
39
40

Option Explicit

Public Sub DistributeButtVertical()

DistributeButt (False)

End Sub

Public Sub DistributeButtHorizontal()

DistributeButt (True)

End Sub

Public Sub DistributeButt(Horizontal As Boolean)

Dim X As Double, Y As Double

Dim NumObjs As Long

Dim s As Shape

Dim First As Boolean

Dim i As Integer

Dim d As Document

Set d = ActiveDocument

NumObjs = d.Selection.Shapes.Count

If NumObjs < 2 Then

i = MsgBox("You should select s few objects first", vbOKOnly, "Distributing")

Exit Sub

End If

d.BeginCommandGroup "Distribute"

First = True

For Each s In d.Selection.Shapes

If Not First Then

If Horizontal Then

s.PositionX = X

Else

s.PositionY = Y

End If

X = s.PositionX + s.SizeWidth

Y = s.PositionY - s.SizeHeight

First = False

d.EndCommandGroup

End Sub

Для удобства желательно вынести кнопки для вызова макроса на панель управления и/или назначить клавиши быстрого запуска. Я вынес кнопки на панель и нарисовал следующие кнопки (изображения кнопок в версии 12 сохраняются в DRAWUIConfig.xml, ранее записывались в cdrbars.cfg): . Вынести кнопки вызова на панель задач и изменить рисунки на них можно командой Tools/Options . На закладке General окна, показанного на рисунке ниже, в поле Tooltip Help задайте строку "Разместить встык вертикально" и для второй процедуры соответственно - "Разместить встык горизонтально".

Следующая процедура предназначена для конвертирования текстовых блоков, созданных в ранних версиях с использованием шрифтов, не поддерживающих Unicode. В этом случае все символы располагаются в таблице с номерами 1..255. При использовании современных шрифтов вместо символов кириллицы обычно отображаются дополнительные символы европейских алфавитов. Подпрограмма перебирает (строка 14) все символы во всех текстовых блоках (строка 13). Из перекодировки исключаются символьные элементы (строка 15). Так как рассматриваются коды символов в кодировке Unicode, и каждый символ имеет размер два байта, то используются соответственно функции AscW и ChrW$. После каждого преобразования для символа устанавливаются свойства, соответствующие русскому языку.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
31
32
33
34
35
36
37
38
39
40
41
42
43
44

Public Sub ConvertRussianUnicode()

' Description: Конвертирует ASCII текст в кириллицу UNICODE

Dim T As Text

Dim s As Shape

Dim d As Document

Dim i As Integer, N As Integer

Dim C As TextRange

Set d = ActiveDocument

'Устанавливаем начало группы для команды отмены

d.BeginCommandGroup "Convert Russian Text To Unicode"

'Перебираем все текстовые элементы текущей страницы

For Each s In d.ActivePage.FindShapes(, cdrTextShape)

For Each C In s.Text.Story.Characters

If C.CharSet <> cdrCharSetSymbol Then

N = AscW(C.WideText)

Select Case N

Case 165

C.WideText = ChrW$(1168): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ґ

Case 168

C.WideText = ChrW$(1025): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ё

Case 170

C.WideText = ChrW$(1028): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Є

Case 175

C.WideText = ChrW$(1031): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'Ї

Case 178

C.WideText = ChrW$(1030): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'І

Case 179

C.WideText = ChrW$(1110): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'і

Case 180

C.WideText = ChrW$(1169): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ґ

Case 184

C.WideText = ChrW$(1105): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'ё

Case 186

C.WideText = ChrW$(1108): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'є

Case 191 To 255

C.WideText = ChrW$(N + 848): C.CharSet = cdrCharSetRussian: C.LanguageID = cdrRussian 'А-я

End Select

End If

Next C

d.EndCommandGroup

End Sub

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
31
32
33
34
35
36
37
38

Sub TextLayer()

' Description: Перемещает весь текст на отдельный слой

' Примечание : Перемещаются ТОЛЬКО объекты текущей страницы

Dim d As Document

Dim p As Page

Dim Lr As Layer

Dim lr1 As Layer

Dim N As Integer

Dim s As Shape

Set d = ActiveDocument

d.BeginCommandGroup "Text Layer"

'Определить, существует ли уже слой Text, если нет, то создать

Set p = ActiveDocument.ActivePage

N = -1

For Each Lr In p.Layers

If Lr.Name = "Text" Then

N = Lr.Index

lr1 = Lr

Exit For

End If

Next Lr

If N < 0 Then

Set lr1 = p.CreateLayer("Text")

N = lr1.Index

End If

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

For Each Lr In p.Layers

If (Lr.Name <> "Text") And (Lr.Name <> "Текст") Then

For Each s In p.FindShapes(, cdrTextShape)

s.MoveToLayer lr1

End If

Next Lr

lr1.Editable = True

d.EndCommandGroup

End Sub

Ссылки по теме