[CDR X5-X8] Отрисовка элемента в фигуре

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Это было сложно, но я таки понял
Дело в том, что при записи макроса идет запись только проделываемых операций, а не того, что вы подумали при этом. То есть, когда вы рисуете линию, он записывает в макрос создание именно этой линии в конкретных координатах, а не "линию с отступом от края фигуры" Тут надо самому лезть в код и менять координаты на переменные. Ну вы же вроде как сами поняли это судя по сообщению #11?

Наконец у меня получилось хотя бы какую то мысль донести)) Вот я сделал макрос, потом запустил на новом листе и линии остались там же.

Код:
Sub ms1()
' Recorded 29.10.2017
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim eff1 As Effect

"здесь рисует контур" - все как нужно
Set eff1 = OrigSelection(1).CreateContour(0, 1.377953, 1, 0, CreateRGBColor(0, 0, 0), CreateRGBColor(0, 0, 0), CreateRGBColor(0, 0, 0), 0, 0, 2, 4, 15#)
eff1.Contour.Offset = 3.543307
eff1.Contour.Offset = 11.811024
eff1.Contour.ContourGroup.AddToSelection
ActiveSelection.Separate
' Recording of this command is not supported: SplitDualSpotObject
"здесь рисую прямоугольник от угла чтобы найти расстояние"
Dim s1 As Shape
Set s1 = ActiveLayer.CreateRectangle(-113.438394, 25.06748, -125.249417, 36.878504)
s1.Rectangle.CornerType = cdrCornerTypeRound
s1.Rectangle.RelativeCornerScaling = True
s1.Fill.ApplyNoFill
s1.Outline.SetPropertiesEx 0.007874, OutlineStyles(0), CreateRGBColor(0, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#, Justification:=cdrOutlineJustificationMiddle
"здесь рисую линию по тем координатам которые нашли раньше"
Dim s2 As Shape
Set s2 = ActiveLayer.CreateLineSegment(-113.438394, 36.878504, -113.438394, -4.899291)
s2.Fill.ApplyNoFill
s2.Outline.SetPropertiesEx 0.007874, OutlineStyles(0), CreateRGBColor(0, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#, Justification:=cdrOutlineJustificationMiddle
Dim dup1 As ShapeRange
Set dup1 = ActiveDocument.CreateShapeRangeFromArray(s1, s2).Duplicate
dup1.Move 56.411228, 0#
dup1.OrderToFront
"переношу линию на другую сторону и удаляю прямоугольник"
dup1.Flip 1
dup1(1).Delete
s1.Delete
End Sub

Грубо говоря просто нужно заменить координаты
Set s2 = ActiveLayer.CreateLineSegment(-113.438394, 36.878504, -113.438394, -4.899291)

На
Dim x,y As Integer

Set s2 = ActiveLayer.CreateLineSegment(ActiveSelection x, ну и так далее)

Просто я так пробовал корел выдает ошибку

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
рубо говоря просто нужно заменить координаты
Set s2 = ActiveLayer.CreateLineSegment(-113.438394, 36.878504, -113.438394, -4.899291)

На
Dim x,y As Integer

Set s2 = ActiveLayer.CreateLineSegment(ActiveSelection x, ну и так далее)

Это вы правильно поняли. Осталось правильно записать данное выражение, чтобы корел не ругался. Тем более, вы ж в сообщении #11 этого вроде добились, не пойму сути вашей проблемы сейчас? Типа такого:

Код:

x1=ActiveSelection.LeftX+100
y1=ActiveSelection.TopY
x2=ActiveSelection.LeftX+100
y2=ActiveSelection.BottomY
Set s2 = ActiveLayer.CreateLineSegment(X1,Y1,X2,Y2)

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Это вы правильно поняли. Осталось правильно записать данное выражение, чтобы корел не ругался. Тем более, вы ж в сообщении #11 этого вроде добились, не пойму сути вашей проблемы сейчас? Типа такого:

Код:

x1=ActiveSelection.LeftX+100 y1=ActiveSelection.TopY x2=ActiveSelection.LeftX+100 y2=ActiveSelection.BottomY Set s2 = ActiveLayer.CreateLineSegment(X1,Y1,X2,Y2)

Спасибо. Начало получаться. Только при этом рисуется одна линия. А при перестановке линии с другой стороны прямоугольника не правильно считает? Скорее всего у меня кривые руки и я не правильно пишу код))))).

Код:
Sub ms1()

Dim s2 As Shape

X1 = ActiveSelection.LeftX + 3
Y1 = ActiveSelection.TopY
X2 = ActiveSelection.LeftX + 3
Y2 = ActiveSelection.BottomY

Set s2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

Dim dup1 As ShapeRange
Set dup1 = ActiveDocument.CreateShapeRangeFromArray(s2).Duplicate
dup1.Move Y2, 0#
dup1.OrderToFront
dup1.Flip 1
End Sub

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
А при перестановке линии с другой стороны прямоугольника не правильно считает?

С другой стороны соответственно будет RightX-3
Вы снова начинаете меня пугать 'hmmm'

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
С другой стороны соответственно будет RightX-3
Вы снова начинаете меня пугать

))) Говорю же руки под код не заточены и голова ищет более сложных решений.
Если так выставить код то как по его действиям я понял он вторую линию строит относительно первой а не относительно прямоугольника?
Sub ms1()

Dim p1 As Shape

X1 = ActiveSelection.LeftX + 3
Y1 = ActiveSelection.TopY
X2 = ActiveSelection.LeftX + 3
Y2 = ActiveSelection.BottomY
Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

"здесь нужно снять выдиление с первой линии"?
Dim p2 As Shape

X1 = ActiveSelection.RightX - 3
Y1 = ActiveSelection.TopY
X2 = ActiveSelection.RightX - 3
Y2 = ActiveSelection.BottomY
Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

End Sub

Простите что такой нудный)) просто никто не учил а делать хочется.

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
относительно первой а не относительно прямоугольника?

Разумеется, когда макрос создает новый объект он выделение на него перекидывает.
Вам надо сразу запомнить LeftX , TopY, RightX и BottomY активного выделения в какие то промежуточные переменные и в дальнейшем плясать уже от этих переменных, ибо после первого же создания объекта AсtiveSelection потреяет актуальность. Как то так

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Разумеется, когда макрос создает новый объект он выделение на него перекидывает.
Вам надо сразу запомнить LeftX , TopY, RightX и BottomY активного выделения в какие то промежуточные переменные и в дальнейшем плясать уже от этих переменных, ибо после первого же создания объекта AсtiveSelection потреяет актуальность. Как то так

Что то из разряда
Dim a,b,c,d As Intrger

Set a = ActiveSection.LeftX
ну и так далее

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
Что то из разряда
Dim a,b,c,d As Intrger

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

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Ну в принципе да, причем эта строка даже не обязательна, в VBA объявлять все переменные просто дело хорошего тона, а вовсе не обязанность.

Set a = ActiveSection.LeftX
таким образом в переменную не поставить?

или просто так нужно
Set a = LeftX

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
Set a = ActiveSection.LeftX
таким образом в переменную не поставить?

Да

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Да

Что то переменную не могу поставить((( подскажите как сделать в данном случае.

_MBK_ · 29.10.2017

Да - это значит вы правильно переменную устанавливаете
А чтото не получается разве таким образом?
А! Set уберите, просто
a=ActiveSelection.LeftX

_MBK_ · 29.10.2017

Вам сильно матчасть надо подтягивать как я погляжу
В данном случае a - просто переменная, не объект
Set не нужен

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Вам сильно матчасть надо подтягивать как я погляжу
В данном случае a - просто переменная, не объект
Set не нужен

Чита параллельно мат часть.
Sub ms1()

Dim p1 As Shape

a = ActiveSelection.LeftX
b = ActiveSelection.TopY
c = ActiveSelection.LeftX
d = ActiveSelection.BottomY

X1 = a + 3
Y1 = b
X2 = c + 3
Y2 = d
Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

Dim p2 As Shape

q = ActiveSelection.RightX
w = ActiveSelection.TopY
e = ActiveSelection.RightX
r = ActiveSelection.BottomY

X1 = q - 3
Y1 = w
X2 = e - 3
Y2 = r
Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

End Sub

Ничего не поменялась по сути я же просто ActiveSelection.Right"-" присваиваю переменную.

_MBK_ · 29.10.2017

НЕЕЕЕЕЕТ!!!!!!!!!!!
Я ж сказал - забудьте про ActiveSelection после первого присвоения! Оно портится сразу же при первом создании нового объекта!

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
НЕЕЕЕЕЕТ!!!
Я ж сказал - забудьте про ActiveSelection после первого присвоения! Оно портится сразу же при первом создании нового объекта!

Sub ms1()

Dim p1 As Shape
"первое присвоение"
a = ActiveSelection.LeftX
b = ActiveSelection.TopY
c = ActiveSelection.LeftX
d = ActiveSelection.BottomY

X1 = a + 3
Y1 = b
X2 = c + 3
Y2 = d
Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

Dim p2 As Shape
"второе присвоение"
q = RightX
w = TopY
e = RightX
r = BottomY

X1 = q - 3
Y1 = w
X2 = e - 3
Y2 = r
Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

End Sub

_MBK_ · 29.10.2017

Вы упорно меня не хотите понять 'fp'

:

Код:

Sub ms1()

Dim p1 As Shape
"первое присвоение"
a = ActiveSelection.LeftX
b = ActiveSelection.TopY
c = ActiveSelection.RightX  ' <-----------------------
d = ActiveSelection.BottomY

X1 = a + 3
Y1 = b
X2 = a + 3         ' <-----------------------
Y2 = d
Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

Dim p2 As Shape
"второе присвоение"


X1 = c - 3   ' <-----------------------
Y1 = b
X2 = c - 3   ' <-----------------------
Y2 = d
Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)




End Sub

Vadimsapr · 29.10.2017

_MBK_ сказал(а):

Вы упорно меня не хотите понять 'fp'

:

Код:

Sub ms1()

Dim p1 As Shape
"первое присвоение"
a = ActiveSelection.LeftX
b = ActiveSelection.TopY
c = ActiveSelection.RightX  ' <-----------------------
d = ActiveSelection.BottomY

X1 = a + 3
Y1 = b
X2 = a + 3         ' <-----------------------
Y2 = d
Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)

Dim p2 As Shape
"второе присвоение"


X1 = c - 3   ' <-----------------------
Y1 = b
X2 = c - 3   ' <-----------------------
Y2 = d
Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)




End Sub

Все понял, спасибо за ваше терпение.
"первое присвоение"
a = ActiveSelection.LeftX
b = ActiveSelection.TopY
c = ActiveSelection.RightX ' <-----------------------
d = ActiveSelection.BottomY

а после уже мы просто работаем с переменными.
Теперь осталось прикрутить чтобы с группой прямоугольников коректно работало ( сделал несколько прям-в, сгруппировал, макрос в каждом сделал линии)
Ну и контур. Буду читать разбираться. Не зря зарегистрировался. Спасибо за сегодняшний урок))).
Может литературу посоветуете?

_MBK_ · 29.10.2017

Vadimsapr сказал(а):
макрос в каждом сделал линии

Макрос в каждом сделает линии если вы по очереди в цикле их перебирать будете. В случае единого селекшна будет две линии

Vadimsapr сказал(а):
Может литературу посоветуете?

Да в принципе F1 в редакторе VBA должно хватать
Но это при условии наличия каких то базовых знаний по программированию на Basic относительно которых меня уже терзают смутные сомнения 'hmmm'

Vadimsapr · 29.10.2017

_MBK_ сказал(а):
Макрос в каждом сделает линии если вы по очереди в цикле их перебирать будете. В случае единого селекшна будет две линии

Да в принципе F1 в редакторе VBA должно хватать
Но это при условии наличия каких то базовых знаний по программированию на Basic относительно которых меня уже терзают смутные сомнения

В Visual Basic применяются три конструкции операторов цикла:

For ... Next
While ... Wend
Do ... Loop

одним из этих циклов

[CDR X5-X8] Отрисовка элемента в фигуре

Участник

Вложения

Пикирующий бомбардировщик

Участник

Вложения

Пикирующий бомбардировщик

Участник

Вложения

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник

Пикирующий бомбардировщик

Участник