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

[lev]

Комментарий модератора: @Vadimsapr, загуглите слово "скриншот", используйте для кодов теги [соdе]...[/соdе]

 

[Vadimsapr]

Sub Macro1()
    Dim p1 As Shape
    Dim p2 As Shape
    Dim N As Integer
    ActiveDocument.Unit = cdrMillimeter
    N = ActiveSelection.Shapes.Count
 
    Dim arrA() As Long
    ReDim arrA(4, N)
  
    For k = 1 To N
        arrA(1, k) = ActiveSelection.Shapes(k).LeftX
        arrA(2, k) = ActiveSelection.Shapes(k).TopY
        arrA(3, k) = ActiveSelection.Shapes(k).RightX
        arrA(4, k) = ActiveSelection.Shapes(k).BottomY
    Next k
  
    For i = 1 To N
        X1 = arrA(1, i) + 3
        Y1 = arrA(2, i)
        X2 = arrA(1, i) + 3
        Y2 = arrA(4, i)
      
        Set p1 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)
      
        X1 = arrA(3, i) - 3
        Y1 = arrA(2, i)
        X2 = arrA(3, i) - 3
        Y2 = arrA(4, i)
      
        Set p2 = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)
    Next i
End Sub

Да, далеко я был ещё. Спасибо всем огромное. Дальше буду сам а то уже слишком я заморочил _MBK_.Но работы ещё много.

 

[Vadimsapr]

Комментарий модератора: @Vadimsapr, загуглите слово "скриншот", используйте для кодов теги [соdе]...[/соdе]

Понял. Спасибо.

 

[_MBK_]

Да, далеко я был ещё. Спасибо всем огромное. Дальше буду сам а то уже слишком я заморочил _MBK_.Но работы ещё много.

Я просто с утюга пишу и на вашем мобильном фото суть ошибки не разумею. Где то вы в синтаксисе напортачили судя по всему.

 

[Vadimsapr]

Я просто с утюга пишу и на вашем мобильном фото суть ошибки не разумею. Где то вы в синтаксисе напортачили судя по всему.

Есть такое. Осталось сделать чтобы все кривые на один слой переходили ну и создать контуры. Мануал в помощь)).

 

[_MBK_]

Они и так у вас все на активном слое или как?

 

[Vadimsapr]

Они и так у вас все на активном слое или как?

Да на активном, где и прямоугольники. Нужно создать новый слой и туда поместить прямые ну и дать название слою.

 

[lev]

Четыре страницы ерундой занимаетесь

вредствами корела

Sub ringo()
  Dim s As Shape, ringofound As Boolean
  ActiveDocument.BeginCommandGroup "Ringo"
  If ActivePage.Layers.Find("ringo") Is Nothing Then ActivePage.CreateLayer ("ringo")
  For Each s In ActiveSelection.Shapes.FindShapes(, cdrRectangleShape)
    ActivePage.Layers("ringo").CreateEllipse s.LeftX, s.TopY, s.RightX, s.BottomY
  Next s
  ActiveDocument.EndCommandGroup
End Sub

 

[Vadimsapr]

Четыре страницы ерундой занимаетесь

Sub ringo()
  Dim s As Shape, ringofound As Boolean
  ActiveDocument.BeginCommandGroup "Ringo"
  ringofound = False
  For Each l In ActivePage.Layers
    If l.Name = "ringo" Then ringofound = True: Exit For
  Next l
  If ringofound = False Then ActivePage.CreateLayer ("ringo")
  For Each s In ActiveSelection.Shapes.FindShapes(, cdrRectangleShape)
    ActivePage.Layers("ringo").CreateEllipse s.LeftX, s.TopY, s.RightX, s.BottomY
  Next s
  ActiveDocument.EndCommandGroup
End Sub

Это в мануале корела пример?

 

[lev]

Это я за пару минут накидал

 

[_MBK_]

CreateEllipse

Дык прямые ж надо

 

[lev]

Макрос нарисовал в них круг или несколько кругов

Про отступы позабыл, но это несложно впихнуть.
Прямоугольник вместо круга - имя метода поменять.
Миш, вот чего ты кучу страниц наблюдаешь, как люди каждый объект выделить программно пытаются? Выясняешь то, что и так понятно из первого же сообщения? И т.д. Ну поменяли посреди кучи бреда круги на прямоугольники и чо?

 

[_MBK_]

У меня, кстати, код из сообщения #60 отрабатывает корректно, без ошибки

 

[Vadimsapr]

У меня, кстати, код из сообщения #60 отрабатывает корректно, без ошибки

У меня тоже работает, но когда начал делать дальше обнаружил что почему то макрос не выдерживает отступы. Допустим задал 63 мм, а когда мерить на листе начинаешь оказывается с одной стороны 63,84 а с другой 63,5 плюс к этому сами прямые смеются внутри прямоугольника т.е снизу не доходят до края а сверху наоборот входят за границы.

 

[_MBK_]

Пример покажите
У меня работает правильно

 

[Vadimsapr]

Пример покажите
У меня работает правильно
Посмотреть вложение 99537

Скриншот не могу сделать. Только если так.

 

[_MBK_]

Скриншот не могу сделать.

Давайте вместе поучимся делать скриншоты или как?
Файл тогда пришлите, что ли?
По вашему фото не понятно ничего снова - правая линия не там где надо?

 

[Alek32]

Замените тип Long на Double. Иначе округляется до целых.

 

[Vadimsapr]

Давайте вместе поучимся делать скриншоты или как?
Файл тогда пришлите, что ли?
По вашему фото не понятно ничего снова - правая линия не там где надо?

На пк нет интернета. Скриншоты то умею делать.

 

[Vadimsapr]

Замените тип Long на Double. Иначе округляется до целых.

Сработало. Спасибо.