MultipleCopyCurveLengthToText_VBA_Coreldraw

MultipleCopyCurveLengthToText

Option Explicit

Sub MultipleCopyCurveLengthToText()

    Dim sr As ShapeRange
    Dim s As Shape
    Dim t As Shape
    Dim lengthVal As Double

    If ActiveSelectionRange.Count = 0 Then
        MsgBox "Please select one or more objects.", vbExclamation
        Exit Sub
    End If

    Set sr = ActiveSelectionRange

    Dim i As Long

    For i = 1 To sr.Count

        Set s = sr(i)

        'Convert to Curve if necessary
        If s.Type <> cdrCurveShape Then
            s.ConvertToCurves
        End If

        If s.Type = cdrCurveShape Then

            'Curve Length (cm)
            lengthVal = s.Curve.Length * 2.54

            'Create Text
            Set t = ActiveLayer.CreateArtisticText(0, 0, _
                Format(lengthVal, "0.0000") & " cm")

            'Move text to object center
            t.centerX = s.centerX
            t.centerY = s.bottomY - 0.5

'            t.Fill.UniformColor.RGBAssign 255, 0, 0

        End If

    Next i

End Sub