免费试用
软件租赁
安装包下载
当前版块:问答社区 > CASS

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

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
积分:62931
KAIGE 2019-11-11 08:49
大神厉害了
回复 0
等级:LV28
积分:28987
hkai2658 2019-11-11 12:19
高手
回复 0
1
悬赏回复规则
1、悬赏期为24小时,从发布时间起算;
2、悬赏期内提问者如设置评论为“精选评论”,视为悬赏结束,该精选评论人将获得本题全部悬赏积分;
3、悬赏期内如提问者未设置“精选评论”,则前5位评论者平分悬赏积分(如仅有一位评论,该评论者获得50%悬赏积分);
4、悬赏积分会自动发放到生态圈账户中,请留意站内信通知。
知道了

距离打开宝箱还剩7

是否花费200积分补签?
确认
取消