помогите с макросом Bitmap + контур

[Linotronic]

помогите с макросом

Существуют некие объекты, вокруг которых есть контур (круг или квадрат).
В языке я не селен, поэтому пользовался простой записью.

Нужно средствами vba осуществить следующее.
Кликаем по контуру, запускаем макрос:
1. Сделать копию контура
2. Увеличить его на 2 мм.
3. Сделать его красным, волосяным.
3. Выделить все.
4. Снять выделение с красного контура.
5. Все что выделено, перевести в битмап 1200 dpi.

Вроде все просто.
Но когда пробуем все тоже самое на другом файле, п. 2 не увеличивает существующий контур, на 2 мм. а задает ему тот размер, который был при записи.
Как это исправить?

 

[Asmussen]

Ответ: помогите с макросом Bitmap + контур

Кидайте код, что записалось.
Если, как я понял, вас в нем все устраивает кроме п.2, исправления будут минимальными. Видимо задается какой-то конкретный размер копии, надо изменить просто, чтобы он вычислялся от оригинального +2мм.

 

[Linotronic]

Ответ: помогите с макросом Bitmap + контур

Да. Со 2 п. не то. Нужно чтоб к сужествующим размерам, того объекта что был выделен перед запуском по x и y добавилось по 2 мм.

Sub res()
    '
    ' Recorded 24.06.2008
    '
    ' Description:
    '                rez
    '
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Dim dup1 As ShapeRange
    Set dup1 = OrigSelection.Duplicate()
    ActiveDocument.ReferencePoint = cdrCenter
    dup1.SetSize 1.577362, 1.49863
    dup1.SetSize 1.577362, 1.577362
    dup1.SetOutlineProperties Color:=CreateCMYKColor(0, 100, 100, 0)
    dup1.SetOutlineProperties 0.003
    ActiveDocument.AddToSelection ActiveLayer.Shapes(1), ActiveLayer.Shapes(2), ActiveLayer.Shapes(3)
    ActiveDocument.AddToSelection ActiveLayer.Shapes(6), ActiveLayer.Shapes(7), ActiveLayer.Shapes(8)
    ActiveDocument.AddToSelection ActiveLayer.Shapes(9), ActiveLayer.Shapes(10), ActiveLayer.Shapes(11)
    ActiveDocument.AddToSelection ActiveLayer.Shapes(12), ActiveLayer.Shapes(13), ActiveLayer.Shapes(14)
    ActiveDocument.AddToSelection ActiveLayer.Shapes(15)
    Dim s1 As Shape
    Set s1 = ActiveSelection.ConvertToBitmapEx(cdrBlackAndWhiteImage, False, False, 1200, cdrNoAntiAliasing, False, False, 95)
End Sub

 

[Linotronic]

Ответ: помогите с макросом Bitmap + контур

p.s.
Если можно, (если конечно в коде этого уже нет) то желательно "принудительно" установить для контура непрерывный тип. Вдруг он будет например пунктиром изначально.

 

[Asmussen]

Ответ: помогите с макросом Bitmap + контур

Тогда возникает еще вопрос.
3. Выделить все.
Все, это конкретно объекты внутри контура, или на странице больше ничего нет кроме этих объектов и контура? Просто если есть, тогда придется еще определять, что у нас внутри него, а что нет.

 

[Linotronic]

Ответ: помогите с макросом Bitmap + контур

Ну вообще, как правило, ничего кроме этого на стр. нет.
Но если есть возможность описать, что выделение происходит только того что внутри контура, было бы еще лучше.

p.s. Хотя нет. Было бы МЕГА-ЛУЧШЕ)

 

[Asmussen]

Ответ: помогите с макросом Bitmap + контур

Вот, всю ночь работал над кодом (шутка).
Попробуйте, должно работать. На всякий случай добавил условие, чтоб запускался только если выделен 1 объект.

Sub res()
Dim Contur As Shape, Dup As Shape
    If Documents.Count = 0 Then Exit Sub
    If ActiveSelection.Shapes.Count <> 1 Then Exit Sub
    ActiveDocument.ReferencePoint = cdrCenter
    ActiveDocument.Unit = cdrMillimeter
    Set Contur = ActiveShape
    Set Dup = Contur.Duplicate
    Dup.SetSize Contur.SizeWidth + 2, Contur.SizeHeight + 2
    Dup.Outline.SetProperties 0.003, , Color:=CreateCMYKColor(0, 100, 100, 0)
    ActivePage.SelectShapesFromRectangle Contur.LeftX, Contur.BottomY, Contur.RightX, Contur.TopY, False
    ActiveSelection.ConvertToBitmapEx cdrBlackAndWhiteImage, False, False, 1200, cdrNoAntiAliasing, False, False, 95
End Sub

 

[Linotronic]

Ответ: помогите с макросом Bitmap + контур

Все работает! Большое спасибо!

 

[dizzy]

Ответ: помогите с макросом Bitmap + контур

Может не совсем правильно понял, но судя по двум темам Вы решаете задачу создания направляющих вокруг этикеток, что потом штампом вырубаются. Затем чтобы выпуски грамотно сделать да посмотреть не зарежеться что-нить важное если не дай бог стопа поедет. То есть по краю штампа снаружи и\или внутри по одному контуру с указанным отступом.

В том плане мя посетила идея дополнить в шейпинге раздел где направляющие ставит. Типа добавить туда вот такую контурную направляющую, кою объектом занести в слой Guides. Сделать не долго, только надо ли такое, вот в чем вопрос.