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

[_MBK_]

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

А точно
Это для заливки s2.Fill.UniformColor.HexValue

 

[_MBK_]

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

Я вообще не понимаю сакральной необходимости создавать параграф, поплясать вокруг него с бубном и потом перевести его в артистик. Атавизм автозаписи макроса?
Почему бы не сделать так
Set t = ActiveDocument.ActiveLayer.CreateArtisticText(0, 0, Round(h / 10, 1) & " x " & Round(w / 10, 1) & " см" & vbCrLf & color , , , , 12)

 

[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
        If s2.Outline.color.HexValue = "#E31E24" Then
            color = "объект красный"
        End If
        If s2.Outline.color.HexValue = "#009846" Then
            color = "объект зеленый"
        End If
        Set t = ActiveDocument.ActiveLayer.CreateArtisticText(s2.CenterX, s2.CenterY, Round(h / 10, 1) & " x " & Round(w / 10, 1) & " см" & vbCrLf & color, , , , 12)
        t.CenterX = s2.CenterX
        t.CenterY = s2.CenterY
        color = ""
        t.Fill.UniformColor.CopyAssign s2.Outline.color
        s2.Ungroup
    Next s2
End Sub

 

[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
        If s2.Outline.color.HexValue = "#E31E24" Then
            color = "объект красный"
        End If
        If s2.Outline.color.HexValue = "#009846" Then
            color = "объект зеленый"
        End If
        Set t = ActiveDocument.ActiveLayer.CreateArtisticText(s2.CenterX, s2.CenterY, Round(h / 10, 1) & " x " & Round(w / 10, 1) & " см" & vbCrLf & color, , , , 12)
        t.CenterX = s2.CenterX
        t.CenterY = s2.CenterY
        color = ""
        t.Fill.UniformColor.CopyAssign s2.Outline.color
        s2.Ungroup
    Next s2
End Sub

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

 

[tohaa]

Я вообще не понимаю сакральной необходимости создавать параграф, поплясать вокруг него с бубном и потом перевести его в артистик. Атавизм автозаписи макроса?
Почему бы не сделать так
Set t = ActiveDocument.ActiveLayer.CreateArtisticText(0, 0, Round(h / 10, 1) & " x " & Round(w / 10, 1) & " см" & vbCrLf & color , , , , 12)

В этом макросе автозаписи небыло. Просто квалификации не хватает сделать все красиво.

 

[_MBK_]

выровнена по левому краю размера

Судя по коду - левый край надписи должен быть в центре объекта

 

[tohaa]

Судя по коду - левый край надписи должен быть в центре объекта

 

[dastin]

А хорошо бы выравнивать по центру размера

попробуйте
& vbCrLf & color, , , , 12)
заменить на
& vbCrLf & color, , , , 12, , , , cdrCenterAlignment)

 

[tohaa]

попробуйте
& vbCrLf & color, , , , 12)
заменить на
& vbCrLf & color, , , , 12, , , , cdrCenterAlignment)

Отлично! То что нужно. Огромное спасибо.

 

[_MBK_]

перенесенная строка с названием цвета выровнена по левому краю размера. А хорошо бы выравнивать по центру размера.

А понял, вам выключка по центру нужна?
В конце , , , , 12, , , , cdrCenterAlignment)