Скрипты VBA в CorelDRAW

Начиная с версии 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 End If X = s.PositionX + s.SizeWidth Y = s.PositionY - s.SizeHeight First = False Next s 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 Next s 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 Next s End If Next Lr lr1.Editable = True d.EndCommandGroup End Sub