[CASS二次开发源代码]VB6+AutoCAD删除多段线指定节点

时间：2019-11-10 16:38 作者：AcadApp 阅读：1736 评论：2

Windows10

其他

CASS9

Public Sub IDeleteNode(ByVal AcadApp As Object) '删除节点
  Dim objEnt As Object
  Dim pnt As Variant, delPnt As Variant, newPnt() As Double
  Dim i As Integer, j As Integer, Iindex As String
  On Error Resume Next
  AcadApp.Application.ActiveDocument.Utility.GetEntity objEnt, pnt, vbCr & vbCr & "指定多段线:"
  If Err Then Err.Clear: Exit Sub
  Select Case objEnt.ObjectName
    Case "AcDbPolyline"
      pnt = objEnt.Coordinates
      If UBound(pnt) <= 3 Then
         MsgBox "多段线节点数小于3。", vbExclamation, "AutoCAD": Exit Sub
      Else
RePnt1:
         delPnt = AcadApp.Application.ActiveDocument.Utility.GetPoint(, vbCr & vbCr & "指定节点:")
         If Err Then Err.Clear: Exit Sub
         pnt = objEnt.Coordinates
         Iindex = ""
         For i = 0 To UBound(pnt) Step 2
             If delPnt(0) = pnt(i) And delPnt(1) = pnt(i + 1) Then Iindex = i: Exit For
         Next i
         If Iindex <> "" Then
            ReDim newPnt(UBound(pnt) - 2): j = 0
            For i = 0 To UBound(pnt) Step 2
                If i <> Int(Iindex) Then
                   newPnt(j) = pnt(i): newPnt(j + 1) = pnt(i + 1): j = j + 2
                End If
            Next i
            objEnt.Coordinates = newPnt
            If UBound(newPnt) <= 3 Then Exit Sub
         End If
         GoTo RePnt1
      End If
    Case "AcDb2dPolyline"
      pnt = objEnt.Coordinates
      If UBound(pnt) <= 5 Then
         MsgBox "多段线节点数小于3。", vbExclamation, "AutoCAD": Exit Sub
      Else
RePnt2:
         delPnt = AcadApp.Application.ActiveDocument.Utility.GetPoint(, vbCr & vbCr & "指定节点:")
         If Err Then Err.Clear: Exit Sub
         pnt = objEnt.Coordinates
         Iindex = ""
         For i = 0 To UBound(pnt) Step 3
             If delPnt(0) = pnt(i) And delPnt(1) = pnt(i + 1) Then Iindex = i: Exit For
         Next i
         If Iindex <> "" Then
            ReDim newPnt(UBound(pnt) - 3): j = 0
            For i = 0 To UBound(pnt) Step 3
                If i <> Int(Iindex) Then
                   newPnt(j) = pnt(i): newPnt(j + 1) = pnt(i + 1): newPnt(j + 2) = pnt(i + 2): j = j + 3
                End If
            Next i
            objEnt.Coordinates = newPnt
            If UBound(newPnt) <= 5 Then Exit Sub
         End If
         GoTo RePnt2
      End If
    Case Else
      MsgBox "不支持的实体类型。", vbExclamation, "AutoCAD"
      Exit Sub
  End Select
End Sub

全部评论

等级:LV30

积分:72050

奔跑蜗牛 2019-11-11 08:49

大神厉害了

等级:LV30

积分:74546

hkai2658 2019-11-11 12:19

高手

1