wmz 发表于 2005-11-28 13:59:00

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

<DIV>以下过程转贴自&lt;&lt;AutoCAD VBA精彩实例教程&gt;&gt;,实际运行中会发生同时删除多个实体的现象,不知何故?</DIV>
<DIV>Sub cmdDel()<BR>&nbsp;&nbsp;&nbsp; ' 删除实体所在图层<BR>&nbsp;&nbsp;&nbsp; On Error Resume Next<BR>&nbsp;&nbsp;&nbsp; Dim objdest As AcadEntity<BR>&nbsp;&nbsp;&nbsp; Dim ptBase As Variant<BR>&nbsp;&nbsp;&nbsp; ThisDrawing.Utility.GetEntity objdest, ptBase, "选择所在层实体&gt;&gt;"<BR>&nbsp;&nbsp;&nbsp; Dim objent As AcadEntity<BR>&nbsp; For Each objent In ThisDrawing.ModelSpace<BR>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If objent.Layer = objdest.Layer Then<BR>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; objent.Delete<BR>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<BR>&nbsp; Next<BR>&nbsp;&nbsp; Dim objLayer As AcadLayer<BR>&nbsp;&nbsp; Set objLayer = ThisDrawing.Layers.Item(objdest.Layer)<BR>&nbsp;&nbsp; objLayer.Delete<BR>End Sub</DIV>

雪山飞狐_lzh 发表于 2005-11-29 08:14:00

你要达到什么效果？

pmq 发表于 2005-11-29 12:02:00

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

wmz 发表于 2005-11-29 12:29:00

lzh741206发表于2005-11-29 8:14:00static/image/common/back.gif你要达到什么效果？


<DIV>选那一层删除那一层.</DIV>
<DIV>但以上例子有时除了删除所选的那一层外,还会附带将别的层(别的一层或多层)也删除了.<BR></DIV>
页: [1]
查看完整版本: [VBA]VBA精彩实例教程删除实体所在图层问题