截取曲线内图形，并复制

偶尔做做怪 · 发表于 2016-7-29 23:02:00

哎，我以为是源码呢。

king20061335 · 发表于 2016-9-8 14:26:00

没有原码也要钱啊，不带这样玩的

ZZX4274382 · 发表于 2016-9-10 19:28:00

过些日子上源码！暂时还在修改

偶尔做做怪 · 发表于 2016-9-12 00:35:00

期待中！！！！！！！

j15tty · 发表于 2016-9-13 08:24:00

论坛关了好久，终于又能上了
现在把主要的一段代码贴上来， Jig_Move这个类是参考才鸟数改写的库函数，主要是图形随鼠标拖动的效果！时间久了源码也丢了！大家也可以参考论坛里其他的文章 Public Sub BreakCurve_Select(Remain_original As Boolean)
      Dim dm As DocumentCollection = Application.DocumentManager
      Dim ed As Editor = dm.MdiActiveDocument.Editor
      '获取当前数据库作为目标数据库
      Dim Db As Database = dm.MdiActiveDocument.Database
      ' Dim 起始图形 As Entity
      Dim pl As Polyline
      Dim C1 As Circle
      Dim select_curve As Curve
      '拾取对象----------------------------------------------------------
      Dim optEnt As New PromptEntityOptions(vbCrLf & "请选择对象")
      Dim resEnt As PromptEntityResult = ed.GetEntity(optEnt)
      If resEnt.Status  PromptStatus.OK Then Return
      Dim _curve As Curve  '定义需要被裁减的曲线
      Dim pts As Point3dCollection = New Point3dCollection '定义交点集合
      Dim pars As DoubleCollection = New DoubleCollection
      Dim objs As DBObjectCollection = New DBObjectCollection
      '定义过滤条件
      Dim value1 As TypedValue = New TypedValue(DxfCode.Start, "circle,arc,line,LWPOLYLINE,spline,ELLIPSE")

      Dim values() As TypedValue = {value1}
      Dim sfilter As New SelectionFilter(values)
      Dim resSel As PromptSelectionResult = ed.SelectAll(sfilter)
      Dim sSet As SelectionSet = resSel.Value
      '得到选择集中所有对象的ObjectId集合.
      Dim ids As ObjectId() = sSet.GetObjectIds()
      Dim objss As DBObjectCollection = New DBObjectCollection
      Using trans As Transaction = Db.TransactionManager.StartTransaction()
         select_curve = trans.GetObject(resEnt.ObjectId, OpenMode.ForRead)
         For Each id As ObjectId In ids  '遍历所有实体，排除裁剪框
            If id  resEnt.ObjectId Then
                  _curve = trans.GetObject(id, OpenMode.ForWrite)
                  pts.Clear() '清空点坐标
                  pars.Clear() '清空点坐标
                  select_curve.IntersectWith(_curve, Intersect.OnBothOperands, pts, New IntPtr(0), New IntPtr(0)) '求交点 pts返回交点
                  If pts.Count  0 Then '如果有交点就分割曲线
                     Dim PT(pts.Count - 1) As Point3d
                     For j As Integer = 0 To pts.Count - 1
                        pts(j) = _curve.GetClosestPointTo(pts(j), False)
                        pars.Add(_curve.GetDistAtPoint(pts(j)))
                        PT(j) = pts(j)
                        'MsgBox(pts(j).ToString)
                     Next
                     Array.Sort(pars.ToArray(), PT)
                     objs = _curve.GetSplitCurves(New Point3dCollection(PT)) '按交点分割CLONE曲线
                     For i As Integer = 0 To objs.Count - 1
                        objss.Add(objs.Item(i))
                        ' MsgBox(objs.Count)
                     Next
                     If Remain_original = False Then _curve.Erase()
                  End If
            End If
         Next
         For Each obj As Entity In objss
            函数库.AppendEntity(obj)
         Next
         trans.Commit()
      End Using
      '-----如果保留原曲线则移动图形，否则打断图形
      If Remain_original = True Then
         Using trans As Transaction = Db.TransactionManager.StartTransaction()
            Dim opl As Polyline = New Polyline
            Dim opll As Polyline = New Polyline '外扩线
            Dim ptss As Point3dCollection = New Point3dCollection
            If TypeOf select_curve Is Polyline Then
                  pl = CType(trans.GetObject(resEnt.ObjectId, OpenMode.ForRead), Polyline)
                  '如果是多段线  则先外扩再将圆弧转换
                  'opl = Off_Polyline(Curve2Polyline(pl, 4), 0.1)
                  Dim 外扩尺寸(4) As Double
                  外扩尺寸(0) = 0.001
                  外扩尺寸(1) = 0.5
                  外扩尺寸(2) = 1
                  外扩尺寸(3) = 5
                  外扩尺寸(4) = 10
                  Dim 标签 As Integer = 1
                  opll = Off_Polyline(pl, 外扩尺寸(标签))
                  函数库.AppendEntity(opll)
                  opl = Curve2Polyline(opll, 8)
                  opll.Erase()
                  '函数库.AppendEntity(opl)
                  For I As Integer = 0 To opl.NumberOfVertices - 1
                     ' MsgBox(pl.GetPoint2dAt(I).X.ToString & "----------" & pl.GetPoint2dAt(I).Y.ToString)
                     ptss.Add(opl.GetPoint3dAt(I))
                     ' MsgBox(ptss(I).ToString)
                  Next
                  Dim optSel As New PromptSelectionOptions
                  Dim Move_resSel As PromptSelectionResult = ed.SelectWindowPolygon(ptss)
                  If Move_resSel.Status  PromptStatus.OK Then
                     ' 函数库.AppendEntity(opl)
                     MsgBox("x")
                     Return
                  End If
                  Dim Move_sSet As SelectionSet = Move_resSel.Value
                  Dim Move_ids As ObjectId() = Move_sSet.GetObjectIds()
                  Dim JM As Jig_Move
                  JM = New Jig_Move(Move_ids)
                  JM.AddObjID(resEnt.ObjectId)
                  JM.testJigCopy()
            ElseIf TypeOf select_curve Is Circle Then
                  C1 = CType(trans.GetObject(resEnt.ObjectId, OpenMode.ForRead), Circle)
                  '如果是圆形  先转换成多段线再外扩
                  opl = Off_Polyline(Curve2Polyline(C1, 1024), 0.1)
                  For I As Integer = 0 To opl.NumberOfVertices - 1
                     ' MsgBox(pl.GetPoint2dAt(I).X.ToString & "----------" & pl.GetPoint2dAt(I).Y.ToString)
                     ptss.Add(opl.GetPoint3dAt(I))
                  Next
                  Dim optSel As New PromptSelectionOptions
                  Dim Move_resSel As PromptSelectionResult = ed.SelectWindowPolygon(ptss)
                  If Move_resSel.Status  PromptStatus.OK Then Return
                  Dim Move_sSet As SelectionSet = Move_resSel.Value
                  Dim Move_ids As ObjectId() = Move_sSet.GetObjectIds()
                  Dim JM As Jig_Move
                  JM = New Jig_Move(Move_ids)
                  JM.testJigCopy()
            End If
            trans.Commit()
         End Using
         '-----删除打断后的生成图形
         Using trans As Transaction = Db.TransactionManager.StartTransaction()
            For Each obj As Entity In objss
                  Dim ent As Entity = trans.GetObject(obj.ObjectId, OpenMode.ForWrite)
                  ent.Erase()
            Next
            trans.Commit()
         End Using
      End If
End Sub
   Public Sub BKS()
      BreakCurve_Select(True)
End Sub

630051689 · 发表于 2017-7-29 15:10:00

‘外扩函数’
Public Shared Function Off_Polyline(pl As Polyline, Dis As Double) As Polyline
      Dim off_cueve As Polyline = New Polyline
      Dim points As New List(Of Point2d)
      Dim PPP As Point2d
      For K As Integer = 0 To pl.NumberOfVertices - 1
         PPP = pl.GetPoint2dAt(K)
         points.Add(PPP)
      Next
      Dim 多边形方向 As CsharpClass.ClockDirection
      多边形方向 = CsharpClass.Polygon.CalculateClockDirection(points, False)
      If 多边形方向 = ClockDirection.Clockwise Then
         Dis = -Dis
         'MsgBox("顺")
      ElseIf 多边形方向 = ClockDirection.Counterclockwise Then
         Dis = Dis
         ' MsgBox("逆")
      ElseIf 多边形方向 = ClockDirection.None Then
         MsgBox("无法判断多边形方向")
      End If
      Dim db As Database = HostApplicationServices.WorkingDatabase
      Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
      Dim offsetCur As DBObjectCollection = pl.GetOffsetCurves(Dis)
      '将偏移的对象加入到数据库
      ' 函数库.AppendEntity(offsetCur(0))
      If TypeOf offsetCur(0) Is Polyline Then
         off_cueve = CType(offsetCur(0), Polyline)
      End If
      Return off_cueve
End Function

630051689 · 发表于 2017-7-29 15:13:00

‘圆弧段转成多边形的函数’，英文很差，中文写的顺手
Public Shared Function Curve2Polyline(_curve As Curve, precise As Double) As Polyline
      Dim pl As Polyline = New Polyline
      Dim dm As DocumentCollection = Application.DocumentManager
      Dim ed As Editor = dm.MdiActiveDocument.Editor
      '获取当前数据库作为目标数据库
      Dim Db As Database = dm.MdiActiveDocument.Database
      Using trans As Transaction = Db.TransactionManager.StartTransaction()
         If TypeOf trans.GetObject(_curve.ObjectId, OpenMode.ForRead) Is Circle Then
            Dim c1 As Circle = New Circle
            c1 = CType(trans.GetObject(_curve.ObjectId, OpenMode.ForRead), Circle)
            ' Dim 分割数 As Integer = c1.Circumference / precise
            Dim 棱边数 As Integer = 1024
            Dim 对角距 As Double = 函数库.求对角距(c1.Radius, 棱边数)
            Dim 角度 As Double = PI * 2 / 棱边数
            Dim pts(棱边数 - 1) As Point2d
            For i As Integer = 0 To 棱边数 - 1
                  pts(i) = New Point2d(c1.Center.X + 对角距 * Cos(角度 * i), c1.Center.Y + 对角距 * Sin(角度 * i))
                  pl.AddVertexAt(i, pts(i), 0, 0, 0)
            Next
            pl.Closed = True
         ElseIf TypeOf trans.GetObject(_curve.ObjectId, OpenMode.ForRead) Is Polyline Then
            Dim PLL As Polyline = New Polyline
            PLL = CType(trans.GetObject(_curve.ObjectId, OpenMode.ForRead), Polyline)
            '---------------判断多边形方向
            Dim points As New List(Of Point2d)
            Dim PPP As Point2d
            For K As Integer = 0 To PLL.NumberOfVertices - 1
                  PPP = PLL.GetPoint2dAt(K)
                  points.Add(PPP)
            Next
            Dim 多边形方向 As CsharpClass.ClockDirection
            多边形方向 = CsharpClass.Polygon.CalculateClockDirection(points, False)
            '--------------判断多边形方向
            Dim 凸度(-1) As Double
            Dim 凸起位置(-1) As Integer
            Dim 圆心(-1) As Point3d
            Dim N As Integer = -1
            Dim PLS(-1) As Polyline
            For i As Integer = 0 To PLL.NumberOfVertices - 1
                  pl.AddVertexAt(i, PLL.GetPoint2dAt(i), 0, 0, 0)
                  If PLL.GetBulgeAt(i)  0 Then
                     N = N + 1
                     ReDim Preserve 凸度(N)
                     ReDim Preserve 凸起位置(N)
                     ReDim Preserve 圆心(N)
                     ReDim Preserve PLS(N)
                     凸度(N) = PLL.GetBulgeAt(i)
                     凸起位置(N) = i
                  End If
            Next
            For J As Integer = N To 0 Step -1
                  Dim 起点 As Point2d '起点坐标
                  Dim 终点 As Point2d '终点坐标
                  Dim pC As Point3d '圆心坐标
                  '  Dim b As Double 'b=Bulge 凸度值
                  Dim L As Double 'L为弦长
                  Dim Lc As Double '弦心距（弦中心到圆弧中心的距离）
                  Dim R As Double '弧半径
                  起点 = PLL.GetPoint2dAt(凸起位置(J))
                  If 凸起位置(J) = PLL.NumberOfVertices - 1 Then
                     终点 = PLL.GetPoint2dAt(0)
                  Else
                     终点 = PLL.GetPoint2dAt(凸起位置(J) + 1)
                  End If
                  ' MsgBox(凸起位置(J).ToString & vbCrLf & 起点.ToString)
                  ' MsgBox(终点.ToString)
                  L = Sqrt((起点.X - 终点.X) ^ 2 + (起点.Y - 终点.Y) ^ 2)
                  R = 0.25 * L * (1 + 凸度(J) ^ 2) / 凸度(J)
                  Lc = 0.25 * L * (1 - 凸度(J) ^ 2) / 凸度(J)
                  ' pC.X = (起点.X + 终点.X) / 2 + Lc / L * (起点.Y - 终点.Y)
                  ' pC.Y = (起点.Y + 终点.Y) / 2 + Lc / L * (终点.X - 起点.X))
                  pC = New Point3d((起点.X + 终点.X) / 2 + Lc / L * (起点.Y - 终点.Y), _
                                 (起点.Y + 终点.Y) / 2 + Lc / L * (终点.X - 起点.X), 0)
                  Dim pts(precise - 1) As Point2d
                  Dim 总弧度 As Double = 4 * Atan(凸度(J))
                  Dim 角度 As Double = 总弧度 / precise
                  Dim 对角距 As Double = R / Cos(角度 / 2)
                  Dim 起点角度 As Double
                  起点角度 = 函数库.求线段绝对角度(函数库.p32d(pC), 起点)
                  PLS(J) = New Polyline
                  For K As Integer = 0 To precise - 1
                     '顺时针方向
                     If 多边形方向 = ClockDirection.Clockwise Then
                        pts(K) = New Point2d(pC.X + R * Cos(起点角度 + 角度 * K), pC.Y + R * Sin(起点角度 + 角度 * K))
                        If 凸度(J) < 0 Then
                              pts(K) = New Point2d(pC.X + 对角距 * Cos(起点角度 + 角度 / 2 + 角度 * K + PI), pC.Y + 对角距 * Sin(起点角度 + 角度 / 2 + 角度 * K + PI))
                        End If
                        '逆时针方向
                     ElseIf 多边形方向 = ClockDirection.Counterclockwise Then
                        pts(K) = New Point2d(pC.X + 对角距 * Cos(起点角度 + 角度 / 2 + 角度 * K), pC.Y + 对角距 * Sin(起点角度 + 角度 / 2 + 角度 * K))
                        If 凸度(J) < 0 Then
                              'pts(K) = New Point2d(pC.X + 对角距 * Cos(起点角度 + 角度 / 2 + 角度 * K + PI), pC.Y + 对角距 * Sin(起点角度 + 角度 / 2 + 角度 * K + PI))
                              pts(K) = New Point2d(pC.X + R * Cos(起点角度 + 角度 * K + PI), pC.Y + R * Sin(起点角度 + 角度 * K + PI))
                        End If
                     ElseIf 多边形方向 = ClockDirection.None Then
                        '按外接多边形考虑
                        pts(K) = New Point2d(pC.X + 对角距 * Cos(起点角度 + 角度 / 2 + 角度 * K), pC.Y + 对角距 * Sin(起点角度 + 角度 / 2 + 角度 * K))
                        If 凸度(J) < 0 Then
                              pts(K) = New Point2d(pC.X + 对角距 * Cos(起点角度 + 角度 / 2 + 角度 * K + PI), pC.Y + 对角距 * Sin(起点角度 + 角度 / 2 + 角度 * K + PI))
                              'pts(K) = New Point2d(pC.X + R * Cos(起点角度 + 角度 * K + PI), pC.Y + R * Sin(起点角度 + 角度 * K + PI))
                        End If
                     End If
                     PLS(J).AddVertexAt(K, pts(K), 0, 0, 0)
                  Next
                  PLS(J).ReverseCurve()
                  For k As Integer = 0 To precise - 1
                     pl.AddVertexAt(凸起位置(J) + 1, PLS(J).GetPoint2dAt(k), 0, 0, 0)
                  Next
                  ReMove_PlSaPt(pl)
            Next
            pl.Closed = True
         End If
         trans.Commit()
      End Using

      Return pl
End Function
Public Shared Function ReMove_PlSaPt(PLL As Polyline) As Polyline
      Dim PL As Polyline = New Polyline
      PL = PLL
      Dim 相同点(-1) As Integer
      Dim 计数器 As Integer = -1
      For M As Integer = 0 To PL.NumberOfVertices - 2  '移除相同点
         If PL.GetPoint3dAt(M) = PL.GetPoint3dAt(M + 1) Then
            计数器 = 计数器 + 1
            ReDim Preserve 相同点(计数器)
            相同点(计数器) = M
            'MsgBox(" SS" & 计数器)
         End If
      Next M
      For N As Integer = 计数器 To 0 Step -1
         PL.RemoveVertexAt(相同点(N))
         ' MsgBox(相同点(N))
      Next
      Return PL
End Function

630051689 · 发表于 2017-7-29 15:16:00

感谢分享程序

xyz002 · 发表于 2017-9-5 11:19:00

收费的，给个源码学习一下，大家共同提高

截取曲线内图形，并复制

发表回复

精选推荐