[VBA]VBA精彩实例教程删除实体所在图层问题

wmz

以下过程转贴自<<AutoCAD VBA精彩实例教程>>,实际运行中会发生同时删除多个实体的现象,不知何故?

Sub cmdDel()
    ' 删除实体所在图层
    On Error Resume Next
    Dim objdest As AcadEntity
    Dim ptBase As Variant
    ThisDrawing.Utility.GetEntity objdest, ptBase, "选择所在层实体>>"
    Dim objent As AcadEntity
  For Each objent In ThisDrawing.ModelSpace
      If objent.Layer = objdest.Layer Then
          objent.Delete
      End If
  Next
   Dim objLayer As AcadLayer
   Set objLayer = ThisDrawing.Layers.Item(objdest.Layer)
   objLayer.Delete
End Sub

雪山飞狐_lzh

你要达到什么效果？

pmq

Sub tcDel() '删除实体所在图层
    On Error Resume Next
    '删除图层中的对象
    Dim objDest As AcadEntity
    Dim ptBase As Variant
    Dim FilterType As Variant
    Dim FilterData As Variant
    Dim Sel As AcadSelectionSet
    Dim Fdata(0) As Variant
    Dim Ftype(0) As Integer
    Dim Pickedobj As AcadEntity
    Dim VByn As String
    Dim TcName As String
    Do
        ThisDrawing.Utility.GetEntity objDest, ptBase, "选择所删除图层中的实体>>"
        If objDest.ObjectName = "" Then
            VByn = MsgBox("请重新选择图层", 5, "删除图层")
            If VByn <> "4" Then
                Exit Sub
            End If
        Else
            Exit Do
        End If
    Loop
    Ftype(0) = 8
    Fdata(0) = objDest.Layer
    FilterType = Ftype
    FilterData = Fdata
    TcName = objDest.Layer
    If ThisDrawing.Layers(TcName).Lock = True Then
        VByn = MsgBox("该图层已锁定,删除", 4, "删除图层")
        If VByn = "6" Then
            ThisDrawing.Layers(TcName).Lock = False '解锁
        Else
            Exit Sub
        End If
    End If
    Set Sel = ThisDrawing.SelectionSets.Add("ssel")
    If Err Then
      Err.Clear
      ThisDrawing.SelectionSets("ssel").Delete
      Set Sel = ThisDrawing.SelectionSets.Add("ssel")
    End If
    Sel.Select acSelectionSetAll, , , FilterType, FilterData
    For Each Pickedobj In Sel
        Pickedobj.Delete
    Next
End Sub

 

wmz

lzh741206发表于2005-11-29 8:14:00你要达到什么效果？

选那一层删除那一层.

但以上例子有时除了删除所选的那一层外,还会附带将别的层(别的一层或多层)也删除了.