Russian version
English version
ОБ АЛЬЯНСЕ | НАШИ УСЛУГИ | КАТАЛОГ РЕШЕНИЙ | ИНФОРМАЦИОННЫЙ ЦЕНТР | СТАНЬТЕ СПОНСОРАМИ SILICON TAIGA | ISDEF | КНИГИ И CD | ПРОГРАММНОЕ ОБЕСПЕЧЕНИЕ | УПРАВЛЕНИЕ КАЧЕСТВОМ | РОССИЙСКИЕ ТЕХНОЛОГИИ | НАНОТЕХНОЛОГИИ | ЮРИДИЧЕСКАЯ ПОДДЕРЖКА | АНАЛИТИКА | КАРТА САЙТА | КОНТАКТЫ
 
Информационный центр
 
Для зарегистрированных пользователей
 
РАССЫЛКИ НОВОСТЕЙ
IT-Новости
Новости компаний
Российские технологии
Новости ВПК
Нанотехнологии
 
Поиск по статьям
 
RSS-лента
Подписаться
Статьи и публикации

Скрипты VBA в CorelDRAW

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
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): [Image]. Вынести кнопки вызова на панель задач и изменить рисунки на них можно командой Tools/Options . На закладке General окна, показанного на рисунке ниже, в поле Tooltip Help задайте строку "Разместить встык вертикально" и для второй процедуры соответственно - "Разместить встык горизонтально".

[Image]

Следующая процедура предназначена для конвертирования текстовых блоков, созданных в ранних версиях с использованием шрифтов, не поддерживающих 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


  Рекомендовать страницу   Обсудить материал Написать редактору  
  Распечатать страницу
 
  Дата публикации: 26.07.2006  

ОБ АЛЬЯНСЕ | НАШИ УСЛУГИ | КАТАЛОГ РЕШЕНИЙ | ИНФОРМАЦИОННЫЙ ЦЕНТР | СТАНЬТЕ СПОНСОРАМИ SILICON TAIGA | ISDEF | КНИГИ И CD | ПРОГРАММНОЕ ОБЕСПЕЧЕНИЕ | УПРАВЛЕНИЕ КАЧЕСТВОМ | РОССИЙСКИЕ ТЕХНОЛОГИИ | НАНОТЕХНОЛОГИИ | ЮРИДИЧЕСКАЯ ПОДДЕРЖКА | АНАЛИТИКА | КАРТА САЙТА | КОНТАКТЫ

Дизайн и поддержка: Silicon Taiga   Обратиться по техническим вопросам  
Rambler's Top100 Rambler's Top100