搬运 圆角转直角 VBA代码

petergh

Public Sub corner_off()
    Dim os As ShapeRange
    Dim s As shape, fir As shape, ci As shape
    Dim nd As Node, nds As Node, nde As Node

    Set os = ActiveSelectionRange
    ud = ActiveDocument.Unit
    ActiveDocument.Unit = CDRMillimeter
On Error GoTo errn
    ActiveDocument.BeginCommandGroup "corners off"
    'Application.Optimization = True
    selec = False
    If os.Shapes.Count = 1 Then
        Set s = os.FirstShape
        If Not s.Curve Is Nothing Then
            For Each nd In s.Curve.Nodes
                If nd.Selected Then
                    selec = True
                    Exit For
                End If
            Next nd
        End If
    End If
   
    If os.Shapes.Count > 1 Or Not selec Then
        os.ConvertToCurves
        For Each s In os.Shapes
            Set nds = Nothing
            Set nde = Nothing
            For k = 1 To 3
            For i = 1 To s.Curve.Nodes.Count
                If i <= s.Curve.Nodes.Count Then
                    Set nd = s.Curve.Nodes(i)
                    If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
                        If Abs(nd.PrevSegment.length - nd.NextSegment.length) < (nd.PrevSegment.length + nd.NextSegment.length) / 30 _
                            And nd.PrevSegment.Type = cdrCurveSegment And nd.NextSegment.Type = cdrCurveSegment Then
                                corner_off_make s, nd.Previous, nd.Next
                        ElseIf Not nd.Next.NextSegment Is Nothing Then
                            If (nd.PrevSegment.Type = cdrLineSegment Or Abs(Abs(nd.PrevSegment.StartingControlPointAngle - nd.PrevSegment.EndingControlPointAngle) - 180) < 1) _
                                And (nd.Next.NextSegment.Type = cdrLineSegment Or Abs(Abs(nd.Next.NextSegment.StartingControlPointAngle - nd.Next.NextSegment.EndingControlPointAngle) - 180) < 1) _
                                And nd.NextSegment.Type = cdrCurveSegment Then
                                    corner_off_make s, nd, nd.Next
                            End If
                       End If
                    End If
                End If
            Next i
            Next k
            
            
        Next s
    ElseIf os.Shapes.Count = 1 And selec Then
        Set nds = Nothing
        Set nde = Nothing
        For Each nd In s.Curve.Nodes
            If Not nd.Selected And Not nd.Next.Selected Then Exit For
        Next nd
        If Not nd Is s.Curve.Nodes.Last Then
            For i = 1 To s.Curve.Nodes.Count
                Set nd = nd.Next
                If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
                If Not nds Is Nothing And nd.Selected Then Set nde = nd
                If nde Is Nothing And nds Is Nothing And nd.Selected Then Set nds = nd
            Next i
            
            If Not nds Is Nothing And Not nde Is Nothing Then
                'ActiveLayer.CreateEllipse2 nds.PositionX, nds.PositionY, nde.PrevSegment.Length / 4
                'ActiveLayer.CreateEllipse2 nde.PositionX, nde.PositionY, nde.PrevSegment.Length / 4
                corner_off_make s, nds, nde
            End If
        End If
    End If
errn:
    Application.Optimization = False
    ActiveDocument.EndCommandGroup
    Application.Refresh
    ActiveDocument.Unit = ud
End Sub

Private Sub corner_off_make(s As shape, nds As Node, nde As Node)
    Dim l1 As shape, l2 As shape
    Dim os As ShapeRange
    Dim SS As shape
    ud = ActiveDocument.Unit
    ActiveDocument.Unit = cdrMillimeter

    Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
    l1.RotationCenterX = nds.PositionX
    l1.RotationAngle = nds.PrevSegment.EndingControlPointAngle + 180
   
    Set l2 = ActiveLayer.CreateLineSegment(nde.PositionX, nde.PositionY, nde.PositionX + s.SizeWidth * 3, nde.PositionY)
    l2.RotationCenterX = nde.PositionX
    l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
   
    Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
    If lcross.Count > 0 Then
        cx = lcross(1).PositionX
        cy = lcross(1).PositionY
        sx = nds.PositionX
        sy = nds.PositionY
        ex = nde.PositionX
        ey = nde.PositionY
        
        l1.Curve.Nodes.Last.PositionX = cx
        l1.Curve.Nodes.Last.PositionY = cy
        l2.Curve.Nodes.Last.PositionX = cx
        l2.Curve.Nodes.Last.PositionY = cy
        
        s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
        Set os = s.BreakApartEx
        oscnt = os.Shapes.Count
        For Each SS In os.Shapes
            If SS.Curve.Nodes.First.PositionX = ex And SS.Curve.Nodes.First.PositionY = ey Then Set s2 = SS
            If SS.Curve.Nodes.Last.PositionX = sx And SS.Curve.Nodes.Last.PositionY = sy Then Set s1 = SS
            If SS.Curve.Nodes.First.PositionX = sx And SS.Curve.Nodes.First.PositionY = sy Then SS.Delete
        Next SS
        
        If s1.Curve.Segments.Last.Type = cdrLineSegment Or Abs(Abs(s1.Curve.Segments.Last.StartingControlPointAngle - s1.Curve.Segments.Last.EndingControlPointAngle) - 180) < 1 Then
            s1.Curve.Nodes.Last.PositionX = lcross(1).PositionX
            s1.Curve.Nodes.Last.PositionY = lcross(1).PositionY
            l1.Delete
        Else
            Set s1 = l1.Weld(s1)
        End If
        If oscnt = 2 Then Set s2 = s1
        If s2.Curve.Segments.First.Type = cdrLineSegment Or Abs(Abs(s2.Curve.Segments.First.StartingControlPointAngle - s2.Curve.Segments.First.EndingControlPointAngle) - 180) < 1 Then
            s2.Curve.Nodes.First.PositionX = lcross(1).PositionX
            s2.Curve.Nodes.First.PositionY = lcross(1).PositionY
            l2.Delete
        Else
            Set s2 = l2.Weld(s2)
        End If
        If oscnt > 2 Then Set s2 = s1.Weld(s2)
        s2.CustomCommand "ConvertTo", "JoinCurves", 0.1
        Set s = s2
    Else
        l1.Delete
        l2.Delete
    End If
    ActiveDocument.Unit = ud
End Sub

next

感谢分享，下载试试看效果

hanlin

亲测，确实可以使用，完美

vipjm

是不是一次只能一个角？？

zzj355

最近也在研究这个转直角可惜没成功楼主就分享了，多个圆角都可以转非常不错

cadme

直接给代码，不错吧。

baruny

代码我们这种莱鸟，只能看看，能不能封装一个给我们也用一下

zhen88666

要怎么在 cdr里面使用那

petergh

vipjm 发表于 2025-8-30 11:23
是不是一次只能一个角？？

一次也可以4个角，选中对象，直接支行代码即可。

tiger7651

曲线导的圆角直接崩掉，要改良