Помогите решить задачу?

[Mikhail_k]

Доброго времени суток, форумчане.
Кто знает, как можно решить эту задачу?

Я не специалист, на рисунке изобразил, попробую описать словами.

Есть какая-то фигура, предположим фигура в форме буквы "Н" по периметру буквы кривая, по углам на кривой стоят точки (узлы). Нужно вытянуть кривую периметра буквы "Н" в длину, чтобы расстояние м\у узлами сохранилось.

как сделать? можно конечно руками, но это долго. может какая то програмка есть которая это делает.

Заранее благодарю!

 

[_MBK_]

Задача настолько специфическая, что я даже сходу не представляю, как руками такое сделать.
Сложность вызывает даже самая простейшая подзадача - разогнуть кривую с сохранением длины.
Только макрос писать.
А зачем вообще такое? Может, вы, на самом деле, странного хотите и вам другого надо?

 

[Mikhail_k]

Я рекламой занимаюсь.
И для изготовления боковин объемных букв, мне нужно на полоске пластика, отметить места загиба боковины (узлов). Чтобы на фрезере вырезать.

 

[~RA~]

кривая

На скриншоте не кривая, а ломаная. Можно же замерить отрезки, а потом отложить их на чём угодно. Времени займет секунды…

 

[_MBK_]

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

 

[_MBK_]

Вот как то так

Sub razvertka()
    ActiveDocument.Unit = cdrMillimeter
       
    Dim OrigSelection As ShapeRange
    Dim CurrentNode As Node
    Set OrigSelection = ActiveSelectionRange
    If OrigSelection.Count = 0 Then
     MsgBox "Nothing selected!", , "Error!"
     Exit Sub
    End If
    If OrigSelection.Count > 1 Then
     MsgBox "Too many selected!", , "Error!"
     Exit Sub
    End If
    If OrigSelection.Shapes(1).Type <> cdrCurveShape Then
     MsgBox "Wrong type of object!", , "Error!"
     Exit Sub
    End If
   
   
    SY = OrigSelection.BottomY - 20
    For i = 1 To OrigSelection.Shapes(1).Curve.SubPaths.Count
     SX = OrigSelection.LeftX
    
     Set crv = ActiveDocument.CreateCurve()
     With crv.CreateSubPath(SX, SY)
     sp = OrigSelection.Shapes(1).Curve.SubPaths(i).Segments.Count
    
     For j = 1 To sp
      ln = OrigSelection.Shapes(1).Curve.SubPaths(i).Segments(j).Length
      SX = SX + ln
      .AppendLineSegment SX, SY
     
     
     Next j
     SY = SY - 20
     End With
     ActiveLayer.CreateCurve (crv)
    Next i
   
End Sub

 

[Mikhail_k]

Вот как то так

Sub razvertka()
    ActiveDocument.Unit = cdrMillimeter
      
    Dim OrigSelection As ShapeRange
    Dim CurrentNode As Node
    Set OrigSelection = ActiveSelectionRange
    If OrigSelection.Count = 0 Then
     MsgBox "Nothing selected!", , "Error!"
     Exit Sub
    End If
    If OrigSelection.Count > 1 Then
     MsgBox "Too many selected!", , "Error!"
     Exit Sub
    End If
    If OrigSelection.Shapes(1).Type <> cdrCurveShape Then
     MsgBox "Wrong type of object!", , "Error!"
     Exit Sub
    End If
  
  
    SY = OrigSelection.BottomY - 20
    For i = 1 To OrigSelection.Shapes(1).Curve.SubPaths.Count
     SX = OrigSelection.LeftX
   
     Set crv = ActiveDocument.CreateCurve()
     With crv.CreateSubPath(SX, SY)
     sp = OrigSelection.Shapes(1).Curve.SubPaths(i).Segments.Count
   
     For j = 1 To sp
      ln = OrigSelection.Shapes(1).Curve.SubPaths(i).Segments(j).Length
      SX = SX + ln
      .AppendLineSegment SX, SY
    
    
     Next j
     SY = SY - 20
     End With
     ActiveLayer.CreateCurve (crv)
    Next i
  
End Sub

_MBK_ спасибо за помощь!
такое дело, я не особо в макросах шарю, подскажите как создать макрос и куда вставить этот код?
заранее благодарю.

 

[Des425]

Попробуйте макрос eCut 6, он платный, но он того стоит.

 

[_MBK_]

_MBK_ спасибо за помощь!
такое дело, я не особо в макросах шарю, подскажите как создать макрос и куда вставить этот код?

Ну примерно как то так
В окне Microsoft Visual Basic жмете правой кнопкой Insert-Module и в новый модуль вставляете этот код