[CDR 2017-2021] Измерение объекта и добавление размера к объекту.

tohaa · 19.02.2019

Здравствуйте.

Задача. Измерить габаритный размер объекта, и подписать этот размер в центре объекта.

Размер я успешно получил, но никак не могу центровать полученный текст по объекту.

Код:

Sub razmer_po_centru()
Dim sh As ShapeRange, w#, h#
ActiveDocument.Unit = cdrMillimeter
Set sh = ActiveSelectionRange
sh(1).GetSize w, h
Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
Set t = s.Text
t.Story.InsertAfter (h & "x" & w & "mm")
s.Text.ConvertToArtistic
End Sub

Помогите центровать текст по объекту.

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

dastin · 19.02.2019

что-то такое должно быть ... это пример из Х5


    ActiveLayer.Shapes(2).AlignToShape cdrAlignLeft + cdrAlignRight + cdrAlignTop + cdrAlignBottom, ActiveLayer.Shapes(1), cdrTextAlignBoundingBox

dastin · 20.02.2019

а это из 2017, в 2018 будет скорее всего так же ... в них выранивание и распределение выглядит иначе

ActiveDocument.CreateShapeRangeFromArray(ActiveLayer.Shapes(2), ActiveLayer.Shapes(1)).AlignAndDistribute 3, 3, 0, 0, False, 2

Sub AlignAndDistribute(MethodH As cdrAlignDistributeH, MethodV As cdrAlignDistributeV, [AlignTo As cdrAlignShapesTo = cdrAlignShapesToLastSelected], [DistributeArea As cdrDistributeArea = cdrDistributeToSelection], [UseOutline As Boolean = False], [TextAlignOrigin As cdrTextAlignOrigin = cdrTextAlignBoundingBox], [PointX As Double], [PointY As Double], [DistributeRect As Rect])

eugeny · 20.02.2019

https://community.coreldraw.com/sdk/api/draw/20/m/shape.alignanddistribute

Вот здесь подробно со всеми переменными и их возможными значениями

tohaa · 20.02.2019

Что-то я упускаю. Код выполняется до перевода в артистик текст. Центровки не происходит. Подскажите пожалуйста.

Код:

Sub razmer_po_centru()
Dim sh As ShapeRange, w#, h#
ActiveDocument.Unit = cdrMillimeter
Set sh = ActiveSelectionRange
sh(1).GetSize w, h
Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
Set t = s.Text
t.Story.InsertAfter (h & "x" & w & "mm")
t.ConvertToArtistic
ActiveDocument.CreateShapeRangeFromArray(ActiveLayer.Shapes(sh), ActiveLayer.Shapes(t)).AlignAndDistribute 3, 3, 0, 0, False, 2
End Sub

dastin · 20.02.2019

в выравнивании должны участвовать два шейпа, а у вас шейпранж ... м.б. так?

Код:

Sub razmer_po_centru()
Dim sh As ShapeRange, w#, h#, s2 As Shape, s As Shape
ActiveDocument.Unit = cdrMillimeter
Set sh = ActiveSelectionRange
Set s2 = sh.All.Group
s2.GetSize w, h
Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
Set t = s.Text
t.Story.InsertAfter (h & " x " & w & " mm")
t.ConvertToArtistic
ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
s2.Ungroup
End Sub

tohaa · 20.02.2019

dastin сказал(а):

в выравнивании должны участвовать два шейпа, а у вас шейпранж ... м.б. так?

Код:

Sub razmer_po_centru()
Dim sh As ShapeRange, w#, h#, s2 As Shape, s As Shape
ActiveDocument.Unit = cdrMillimeter
Set sh = ActiveSelectionRange
Set s2 = sh.All.Group
s2.GetSize w, h
Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
Set t = s.Text
t.Story.InsertAfter (h & " x " & w & " mm")
t.ConvertToArtistic
ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
s2.Ungroup
End Sub

Отлично! Спасибо! Работает.

tohaa · 20.02.2019

В развитии этого макроса хочется получить цвет обводки фигуры и назначить его тексту, который выравнивается по центру.

Alek32 · 21.02.2019

Код:

Sub razmer_po_centru()
    Dim sh As ShapeRange, w#, h#, s2 As Shape, s As Shape
    ActiveDocument.Unit = cdrMillimeter
    Set sh = ActiveSelectionRange
    Set s2 = sh.All.Group
    s2.GetSize w, h
    Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
    Set t = s.Text
    t.Story.InsertAfter (h & " x " & w & " mm")
    t.ConvertToArtistic
    s.Fill.UniformColor.RGBAssign s2.Outline.Color.RGBRed, s2.Outline.Color.RGBGreen, s2.Outline.Color.RGBBlue
    ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
    s2.Ungroup
End Sub

tohaa · 21.02.2019

Alek32 сказал(а):

Код:

Sub razmer_po_centru()
    Dim sh As ShapeRange, w#, h#, s2 As Shape, s As Shape
    ActiveDocument.Unit = cdrMillimeter
    Set sh = ActiveSelectionRange
    Set s2 = sh.All.Group
    s2.GetSize w, h
    Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
    Set t = s.Text
    t.Story.InsertAfter (h & " x " & w & " mm")
    t.ConvertToArtistic
    s.Fill.UniformColor.RGBAssign s2.Outline.Color.RGBRed, s2.Outline.Color.RGBGreen, s2.Outline.Color.RGBBlue
    ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
    s2.Ungroup
End Sub

Спасибо. Вот более короткая команда.

s.Fill.UniformColor.CopyAssign s2.Outline.Color

Alek32 · 21.02.2019

tohaa сказал(а):
Спасибо. Вот более короткая команда.

s.Fill.UniformColor.CopyAssign s2.Outline.Color

Вот для всех выделенных объектов:

Код:

Sub razmer_po_centru()
    ActiveDocument.Unit = cdrMillimeter
    Set OrigSelection = ActiveSelectionRange
    For Each s2 In OrigSelection
        Dim sh As ShapeRange, w#, h#, s As Shape
        s2.GetSize w, h
        Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
        Set t = s.Text
        t.Story.InsertAfter (h & " x " & w & " mm")
        t.ConvertToArtistic
        s.Fill.UniformColor.CopyAssign s2.Outline.Color
        ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
        s2.Ungroup
    Next s2
End Sub

tohaa · 21.02.2019

Alek32 сказал(а):

Вот для всех выделенных объектов:

Код:

Sub razmer_po_centru()
    ActiveDocument.Unit = cdrMillimeter
    Set OrigSelection = ActiveSelectionRange
    For Each s2 In OrigSelection
        Dim sh As ShapeRange, w#, h#, s As Shape
        s2.GetSize w, h
        Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
        Set t = s.Text
        t.Story.InsertAfter (h & " x " & w & " mm")
        t.ConvertToArtistic
        s.Fill.UniformColor.CopyAssign s2.Outline.Color
        ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
        s2.Ungroup
    Next s2
End Sub

Вот это да! Идеально) Спасибо!!!

tohaa · 23.03.2019

Добрый день уважаемые товарищи.

У меня возникла потребность в доработке этого прекрасного макроса.

Сейчас он измеряет выделенные объекты и образмеривает их.

Нужно добавить условие "Если объект красный 0.100.100.0 - делать подпись внутри измеренного объекта - "размер + объект красный".
Делать сравнение и подпись нужно с 13 цветами.
Если цвет объекта не совпадает с таблицей сравнения - просто проставлять размер.

Как? В какую сторону копать?

_MBK_ · 23.03.2019

В смысле в какую? Проверка на совпадение по цвету (Fill.UniformColor) если совпадает то добавить к подписи цвет. Реализация чего именно из описанного непонятна?

tohaa · 23.03.2019

_MBK_ сказал(а):
В смысле в какую? Проверка на совпадение по цвету (Fill.UniformColor) если совпадает то добавить к подписи цвет. Реализация чего именно из описанного непонятна?

Я бы хотел кусок кода, выполняющий проверку совпадения цвета или подобный. Я совсем не программист).

Alek32 · 23.03.2019

tohaa сказал(а):
Я бы хотел кусок кода, выполняющий проверку совпадения цвета или подобный. Я совсем не программист).

Код:

Sub razmer_po_centru()
    ActiveDocument.Unit = cdrMillimeter
    Set OrigSelection = ActiveSelectionRange
    For Each s2 In OrigSelection
        Dim sh As ShapeRange, w#, h#, s As Shape
        Dim color As String
        s2.GetSize w, h
        Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
        Set t = s.Text
        
        If s2.Outline.color.CMYKCyan = 0 And _
        s2.Outline.color.CMYKMagenta = 100 And _
        s2.Outline.color.CMYKYellow = 100 And _
        s2.Outline.color.CMYKBlack = 0 Then
            color = " объект красный"
        End If
        
        If s2.Outline.color.CMYKCyan = 100 And _
        s2.Outline.color.CMYKMagenta = 0 And _
        s2.Outline.color.CMYKYellow = 100 And _
        s2.Outline.color.CMYKBlack = 0 Then
            color = " объект зеленый"
        End If
        
        t.Story.InsertAfter (h & " x " & w & " mm" & color)
        color = ""
        t.ConvertToArtistic
        s.Fill.UniformColor.CopyAssign s2.Outline.color
        ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
        s2.Ungroup
    Next s2
End Sub

tohaa · 23.03.2019

Alek32 сказал(а):

Код:

Sub razmer_po_centru()
    ActiveDocument.Unit = cdrMillimeter
    Set OrigSelection = ActiveSelectionRange
    For Each s2 In OrigSelection
        Dim sh As ShapeRange, w#, h#, s As Shape
        Dim color As String
        s2.GetSize w, h
        Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment)
        Set t = s.Text
       
        If s2.Outline.color.CMYKCyan = 0 And _
        s2.Outline.color.CMYKMagenta = 100 And _
        s2.Outline.color.CMYKYellow = 100 And _
        s2.Outline.color.CMYKBlack = 0 Then
            color = " объект красный"
        End If
       
        If s2.Outline.color.CMYKCyan = 100 And _
        s2.Outline.color.CMYKMagenta = 0 And _
        s2.Outline.color.CMYKYellow = 100 And _
        s2.Outline.color.CMYKBlack = 0 Then
            color = " объект зеленый"
        End If
       
        t.Story.InsertAfter (h & " x " & w & " mm" & color)
        color = ""
        t.ConvertToArtistic
        s.Fill.UniformColor.CopyAssign s2.Outline.color
        ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 3, 3, 0, 0, False, 2
        s2.Ungroup
    Next s2
End Sub

Спасибо Добрый человек. Попробую.

_MBK_ · 23.03.2019

Alek32 сказал(а):
If s2.Outline.color.CMYKCyan = 100 And _ s2.Outline.color.CMYKMagenta = 0 And _ s2.Outline.color.CMYKYellow = 100 And _ s2.Outline.color.CMYKBlack = 0 Then color = " объект зеленый" End If

Проще так

Код:

if s2.Outline.UniformColor.HexValue="#00FF00" then
...
end if

tohaa · 23.03.2019

_MBK_ сказал(а):
Проще так

Код:

if s2.Outline.UniformColor.HexValue="#00FF00" then ... end if

Код:

If s2.Outline.color.HexValue = "#009846" Then
        
            color = " зеленый"
        End If

Вот так работает. Uniform не работает.

tohaa · 23.03.2019

Не получается перенести название цвета на другую строку. что я делаю не так?

Код:

t.Story.InsertAfter (Round(h / 10, 1) & " x " & Round(w / 10, 1) & " см" & vbCrLf & color)

[CDR 2017-2021] Измерение объекта и добавление размера к объекту.

Участник

Некромант-любитель

Некромант-любитель

Участник

Некромант-любитель

Участник

Участник

Участник

Участник

Участник

Участник

Участник

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

Участник

Участник

Участник

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

Участник

Участник