[CDR X5-X8] Макрос добавления меток объекту

  • Автор темы Автор темы Seiros
  • Дата начала Дата начала
S

Seiros

Участник
Топикстартер
Сообщения
4
Реакции
0
Здравствуйте.
Прошу помочь с макросом
Задача раскинуть 4 креста 5х5мм 0,25 абрисом по осям выделенного объекта на удалении 5мм
Цвет абриса как у объекта(или цветом совмещения) с включенным наложением.
Если возможно то верхний крест сделать не "5х5" а "8х5"

По возможности хотел бы получить не заблокированный макрос для понятия основ команд, и переделки макроса в случае необходимости.

Заранее спасибо.
 
Зачем вам эти заморочки?
Есть же полно готовых, я к примеру пользуюсь dizzy CropMaker
На форуме совсем недавно пробегал аналогичный
 
Seiros сказал(а):
Здравствуйте.
Прошу помочь с макросом
Задача раскинуть 4 креста 5х5мм 0,25 абрисом по осям выделенного объекта на удалении 5мм
Цвет абриса как у объекта(или цветом совмещения) с включенным наложением.
Если возможно то верхний крест сделать не "5х5" а "8х5"

По возможности хотел бы получить не заблокированный макрос для понятия основ команд, и переделки макроса в случае необходимости.

Заранее спасибо.
Нажмите, чтобы раскрыть...



Sub metki02()
Dim sr As ShapeRange, sCirc As Shape, sLine2 As Shape, sr2 As New ShapeRange, s As Shape
Dim x#, y#, w#, h#
Dim dCropRadius#

ActiveDocument.Unit = cdrMillimeter

dCropRadius = 1

Set sr = ActiveSelectionRange
If sr.Count = 0 Then Exit Sub

ActiveDocument.BeginCommandGroup "CropMarkCustom"

sr.GetBoundingBox x, y, w, h
Set sCirc = ActiveLayer.CreateLineSegment(0, 0, dCropRadius * 6, 0): sr2.Add sCirc 'dlina linii v mm

Set sLine2 = ActiveLayer.CreateLineSegment(0, 0, 0, dCropRadius * 6) 'dlina linii v mm

sLine2.AlignToShape cdrAlignHCenter, sCirc: sLine2.AlignToShape cdrAlignVCenter, sCirc: sr2.Add sLine2

Set s = sr2.Group
Set sr2 = New ShapeRange: sr2.Add s
s.AlignToShapeRange cdrAlignLeft, sr
ActiveDocument.ReferencePoint = cdrCenter
s.SetPositionEx cdrCenter, s.PositionX, y - 6 'sdvig kresta verh i niz
Set s = s.Duplicate(0, h + (6 * 2))
sr2.Add s
Set s = sr2.Group
With s
.Outline.Width = 0.25 'tolshina linii v mm

.Outline.Color.CMYKAssign 0, 0, 0, 100 'cvet kresta
.CreateSelection
.Name = "left Crop Marks"
.Move -9, 0# 'sdvig kresta vlevo
End With

Dim sr0 As ShapeRange, sCirc0 As Shape, sLine20 As Shape, sr20 As New ShapeRange, s0 As Shape
' Dim x#, y#, w#, h#
Dim dCropRadius0#

dCropRadius0 = 1

Set sr0 = ActiveSelectionRange
If sr0.Count = 0 Then Exit Sub

ActiveDocument.BeginCommandGroup "CropMarkCustom"

sr.GetBoundingBox x, y, w, h
Set sCirc0 = ActiveLayer.CreateLineSegment(0, 0, dCropRadius0 * 6, 0): sr20.Add sCirc0 'dlina linii v mm

Set sLine20 = ActiveLayer.CreateLineSegment(0, 0, 0, dCropRadius0 * 6) 'dlina linii v mm

sLine20.AlignToShape cdrAlignHCenter, sCirc0: sLine20.AlignToShape cdrAlignVCenter, sCirc0: sr20.Add sLine20

Set s0 = sr20.Group
Set sr20 = New ShapeRange: sr20.Add s0
s0.AlignToShapeRange cdrAlignRight, sr
ActiveDocument.ReferencePoint = cdrCenter
s0.SetPositionEx cdrCenter, s0.PositionX, y - 6 'sdvig kresta verh i niz
Set s0 = s0.Duplicate(0, h + (6 * 2))
sr20.Add s0
Set s0 = sr20.Group
With s0
.Outline.Width = 0.25 'tolshina linii v mm

.Outline.Color.CMYKAssign 0, 0, 0, 100 'cvet kresta
.CreateSelection
.Name = "right Crop Marks"
.Move 9, 0#
End With

End Sub
Работает надежно. Ставит меточки вокруг выделенных объектов. Читайте комментарии, чтобы настроить под себя.
 
Для ответа нужно войти/зарегистрироваться
Верх Низ