VBA to rotate an open curve so that the end nodes are perfectly aligned along a horizontal plane

  • Sub Macro1()
    Dim n As Node, x1 As Double, y1 As Double, x2 As Double, y2 As Double, os As ShapeRange
    ActiveDocument.Unit = cdrMillimeter
    Set os = ActiveSelectionRange
    If os.Count <> 1 Then MsgBox ("Select one shape and run macro again!"): Exit Sub
    ActiveShape.Curve.Nodes.First.GetPosition x1, y1
    ActiveShape.Curve.Nodes.Last.GetPosition x2, y2
    If x2 <> x1 Then k = -1 Else myangle = -90: GoTo here:
    With os(1)
    .RotationCenterX = x1
    .RotationCenterY = y1
    End With
    myangle = Atn((y2 - y1) / (x2 - x1)) * 180 / 3.14159265358979
    here:
    os(1).Rotate k * myangle
    End Sub

  • God damn it Mek! A lovely bit of code right there sir!

    Beat me to the post and much better than my dunderhead approach of using reference shapes and 'GetPerpendicularAt'.

     Well, I've written it now and at least it shows the power of using math over brute force!

    Sub AlignSubpathEndsArc()
        If ActiveShape Is Nothing Then Exit Sub
        
        Dim startSh As Shape
            Set startSh = ActiveSelectionRange(1)
            If startSh.Curve.SubPaths.Count > 1 Then Exit Sub
            If startSh.Curve.SubPaths.First.Closed = True Then Exit Sub
            
        Dim tolerance#: tolerance = 0.01
        
        Dim startNode As Node, endNode As Node
            Set startNode = startSh.Curve.Nodes.First
            Set endNode = startSh.Curve.Nodes.Last
            
        Dim startNodeX#, startNodeY#
            startNodeX = startNode.PositionX
            startNodeY = startNode.PositionY
            
        Dim endNodeX#, endNodeY#
            endNodeX = endNode.PositionX
            endNodeY = endNode.PositionY
    
        Dim shapeNeedsRotating As Boolean
            If Abs(startNodeY - startNodeY) > tolerance Then 'then Nodes are not aligned horizontally
                If Abs(endNodeX - startNodeX) < tolerance Then
                    startSh.Rotate 90 'Nodes are apart and near vertical aliengment
                    shapeNeedsRotating = False
                Else
                    shapeNeedsRotating = True
                End If
            Else
                shapeNeedsRotating = True
            End If
    
        Dim refLine As Shape, refCircle As Shape, refHorizonLine As Shape
        Dim horizonAngle#, lineAngle#
        Dim rotAmount#
        
            If shapeNeedsRotating = True Then
                startSh.SetRotationCenter startNodeX, startNodeY
                Set refLine = ActiveLayer.CreateLineSegment(startNodeX, startNodeY, endNodeX, endNodeY): refLine.Outline.Color.CMYKAssign 0, 100, 0, 0
                Set refCircle = ActiveLayer.CreateEllipse2(startNodeX, startNodeY, refLine.Curve.Length, refLine.Curve.Length): refCircle.Outline.Color.CMYKAssign 0, 100, 0, 0
                Set refHorizonLine = ActiveLayer.CreateLineSegment(refCircle.LeftX, refCircle.CenterY, refCircle.RightX, refCircle.CenterY): refHorizonLine.Outline.Color.CMYKAssign 100, 0, 0, 0
                horizonAngle = refHorizonLine.Curve.Segments.First.GetPerpendicularAt(0.5)
                lineAngle = refLine.Curve.Segments.First.GetPerpendicularAt(0.5)
                rotAmount = horizonAngle - lineAngle
                startSh.Rotate rotAmount
            End If
    
    End Sub