搬运圆角转直角 VBA代码

petergh 发表于昨天 09:16

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 发表于昨天 10:05

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

hanlin 发表于昨天 10:07

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

vipjm 发表于昨天 11:23

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

zzj355 发表于昨天 11:51

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

cadme 发表于昨天 14:30

直接给代码，不错吧。

baruny 发表于昨天 14:52

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

zhen88666 发表于昨天 14:59

要怎么在 cdr里面使用那

petergh 发表于昨天 17:01

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

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

tiger7651 发表于昨天 17:10

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

页: [1] 2

华印's Archiver

搬运 圆角转直角 VBA代码

搬运圆角转直角 VBA代码