[CDR 2017-2021] Задать длину кривой

[mnemonix]

В Кореле, как мне кажется, нет функции задания длины кривой. Вопрос: можно ли это сделать макросом?

 

[_MBK_]

В Кореле, как мне кажется, нет функции задания длины кривой. Вопрос: можно ли это сделать макросом?

Что значит "задание длины кривой? Можно измерить длину кривой, посчитать коэффициент от заданной длины и смасштабировать кривую пропорционально на него. Или я неправильно понял хотелку?

 

[mnemonix]

Можно и так, но хочется без лишних движений задать требуемую длину и получить результат.

 

[mnemonix]

Наверное копать здесь, высчитывать коэффициент и назначать кривой.

Sub CurveLength()
Dim s As Shape
Set s = ActiveSelection.Shapes(1)
If s.Type = cdrCurveShape Then
MsgBox "The length of the curve is: " _
& vbCrLf & s.Curve.Length & " mm"
End If
End Sub

 

[_MBK_]

Наверное копать здесь, высчитывать коэффициент и назначать кривой.

Sub CurveLength()
Dim s As Shape
Set s = ActiveSelection.Shapes(1)
If s.Type = cdrCurveShape Then
MsgBox "The length of the curve is: " _
& vbCrLf & s.Curve.Length & " mm"
End If
End Sub

Да именно

 

[dastin]

и назначать кривой

как-то так ...

Sub CurveL()
Dim s As Shape
Dim x As Double, y As Double, k As Double
Dim dc As Double, dc2 As Double, L As String
ActiveDocument.Unit = cdrMillimeter

ActiveDocument.BeginCommandGroup "CurveL"
Set s = ActiveShape
If s.Type = cdrCurveShape Then
s.GetSize x, y
dc = s.Curve.length
L = InputBox("Curve Length = " & dc & " mm" _
& vbNewLine & _
"Set new Length")
If Len(L) = 0 Then Exit Sub Else dc2 = Val(L)
k = dc2 / dc
s.SetSize x * k, y * k
Else
MsgBox "Selected Shape Not Curve"
Exit Sub
End If
ActiveDocument.EndCommandGroup
End Sub

 

[Titrex]

В обновлении CorelDraw 24.2 в инструменте "Преобразовать" > "Размер" появилось дополнение, в том числе может делать и это

Может работать и с группой объектов... +видео пример

 

[mnemonix]

dastin, преогромное спасибо, коротко и изящно! Всё прекрасно работает.
Добавил обводку hairline, ConvertToCurves и обработку, когда ничего не выделено.
Проверил, работает и с текстом.

Sub CurveL()
Dim s As Shape
Dim x As Double, y As Double, k As Double
Dim dc As Double, dc2 As Double, L As String
ActiveDocument.Unit = cdrMillimeter

    On error goto ErrHandler     
    ActiveSelection.Outline.Width = 0.0762
      
ActiveDocument.BeginCommandGroup "CurveL"
Set s = ActiveShape
  
    s.ConvertToCurves

If s.Type = cdrCurveShape Then
s.GetSize x, y
dc = s.Curve.length
L = InputBox("Curve Length = " & dc & " mm" _
& vbNewLine & _
"Set new Length")
If Len(L) = 0 Then Exit Sub Else dc2 = Val(L)
k = dc2 / dc
s.SetSize x * k, y * k
Else
MsgBox "Selected Shape Not Curve"
Exit Sub
End If
ActiveDocument.EndCommandGroup

        ErrHandler:
End Sub

 

[dastin]

и с текстом

аккуратнее - если строка большая или их несколько - при переводе в кривые будет группа кривых

 

[mnemonix]

аккуратнее - если строка большая или их несколько

Этого не понадобится, но спасибо за предупреждение