Пунктирные и размерные линии на VBA CorelDraw

Займёмся расширением кругозора по командам VBA CorelDraw. В этой небольшой заметке мы научимся создавать пунктирные и размерные линии с помощью макроса VBA.

Не буду заставлять вас долго ждать, вот функция VBA, которая рисует пунктирную линию:

Sub DrawCurve(node1X, node1Y, node2X, node2Y)
    Dim s As Shape
    Dim crv As Curve
    Dim sp As SubPath
    Dim cdrType As cdrDimensionType
    Set crv = CreateCurve(ActiveDocument)
    Set sp = crv.CreateSubPath(node1X, node1Y)
    sp.AppendLineSegment node1X, node1Y, False
    sp.AppendLineSegment node2X, node2Y, False
    Set s = ActiveLayer.CreateCurve(crv)
    s.Outline.SetProperties Width:=0.2, Style:=OutlineStyles(8), DashDotLength:=4#
End Sub

В строках 2-5 мы вводим необходимые переменные, в шестой инициализируем кривую для данного активного документа. В строках 7-9 добавляем сегмент и точки для данного сегмента (как бы конструируем контур). В 10 непосредственно создаем абрис, а в 11 устанавливаем необходимые параметры для него: толщина и тип прерывистой линии. Если теперь после выполнения данного кода заглянуть в параметры созданного объекта, то увидим примерно такую картину:



Дальше для этого абриса необходимо проставить размерную линии. И для этого есть встроенные средства CоrelDraw. Готовая функция для рисования:

Sub DrawRazmer(x, sx, y, sy, cdrType, r)
    Dim pt1 As SnapPoint, pt2 As SnapPoint
    Dim s As Shape
    ActiveDocument.Unit = cdrMillimeter
    Set pt1 = CreateSnapPoint(x, y)
        
    If cdrType = cdrDimensionHorizontal Then
        Set pt2 = CreateSnapPoint(x + sx, y)
        Set s = ActiveLayer.CreateLinearDimension(cdrType, pt1, pt2, True, , , cdrDimensionStyleDecimal, False, False, Placement:=cdrDimensionWithinLine, HorizontalText:=False, BoxedText:=False, LeadingZero:=True, Prefix:="", Suffix:="", OutlineWidth:=-1, Arrows:=ArrowHeads(1), OutlineColor:=CreateCMYKColor(75, 68, 67, 90), TextFont:="Verdana", TextSize:=10, TextColor:=CreateCMYKColor(75, 68, 67, 90))
        s.Dimension.TextShape.SetPosition x + sx / 2, y + r
    Else
        Set pt2 = CreateSnapPoint(x, y + sy)
        Set s = ActiveLayer.CreateLinearDimension(cdrType, pt1, pt2, True, , , cdrDimensionStyleDecimal, False, False, Placement:=cdrDimensionWithinLine, HorizontalText:=False, BoxedText:=False, LeadingZero:=True, Prefix:="", Suffix:="", OutlineWidth:=-1, Arrows:=ArrowHeads(1), OutlineColor:=CreateCMYKColor(75, 68, 67, 90), TextFont:="Verdana", TextSize:=10, TextColor:=CreateCMYKColor(75, 68, 67, 90))
        s.Dimension.TextShape.SetPosition x + r, y
    End If
End Sub

Здесь мы на вход принимаем координаты первоначальной точки, смещение, направление (горизонтально или вертикально), а также отступ. Интересно, что функция CreateLinearDimension немного по-разному работает в разных версиях CorelDraw. Например, в шестом кореле отключение отображения единиц измерения работает, а вот в 2018 – нет, все равно ставятся миллиметры или дюймы.
заметки, макросы, CorelDraw, VBA