快速选取一层的所有对象,进行相应的操作

雪山飞狐_lzh · 发表于 2004-5-19 09:15:00

Sub QSelLayerControl()
'程序功能:快速选取一层的所有对象,进行相应的操作
   Dim i    As AcadEntity
   Dim ss As AcadSelectionSet
   Dim ft(0) As Integer, fd(0)
   Dim pLayer As String
   Dim pControl As String
   pLayer = ThisDrawing.Utility.GetString(0, vbCrlLf & "请输入层名:")
   ft(0) = 8: fd(0) = pLayer
   Set ss = ThisDrawing.ActiveSelectionSet
   ss.Clear
   ss.Select acSelectionSetAll, , , ft, fd
   If ss.Count = 0 Then
   ss.Delete
   ThisDrawing.Utility.Prompt "层内没有对象或层不存在!"
   Else
   ThisDrawing.Utility.InitializeUserInput 1, "Move Copy Erase"
   pControl = ThisDrawing.Utility.GetKeyword(vbCr & "请输入操作名[Move(移动)/Copy(复制)/Erase(删除)]:")
   ThisDrawing.SendCommand "." & pControl & vbCr & "p" & vbCr & vbCr
   End If
'附:将下列代码Copy到acad200?doc.lsp中,执行命令QSLC
'    (defun CSLC()
'    (setvar "cmdecho" 0)
'    (command "-vbarun" "qsellayercontrol")
'    (setvar "cmdecho" 1)
'    (princ)
'    )
End Sub

woshiyu121 · 发表于 2004-6-3 15:40:00

你好！
我是一个菜鸟，我不太会用你这个程序，能否给我指点一下？谢谢了。我的E ：woshiyu1217@126.com

雪山飞狐_lzh · 发表于 2004-6-3 16:01:00

上面是VBA代码，你要把它Copy到VBA的代码窗口里保存，在加载应用程序的启动组把保存的dvb文件加入，再把下面的Lisp代码Copy到acad200?doc.lsp中
(defun CSLC()
(setvar "cmdecho" 0)
(command "-vbarun" "qsellayercontrol")
(setvar "cmdecho" 1)
(princ)
)

gjliang · 发表于 2004-7-15 20:08:00

修改以下看看 Sub qselect()
Dim tsel As AcadSelectionSet
Dim entry As AcadEntity
Dim tpic As Variant
Dim layerstr As String
On Error Resume Next
Set tsel = ThisDrawing.SelectionSets("topirolss")
If Err Then
Err.Clear
Set tsel = ThisDrawing.SelectionSets.Add("topirolss")
tsel.Clear
End If
ThisDrawing.Utility.GetEntity entry, tpic, "选择实体："
If Err Then
Err.Clear
Exit Sub
End If
layerstr = entry.Layer
   Dim FilterType(0) As Integer
   Dim FilterData(0) As Variant
   FilterType(0) = 8
   FilterData(0) = layerstr
   tsel.Select acSelectionSetAll, , , FilterType, FilterData
   tsel.Highlight (True)
   If tsel.Count = 0 Then
   tsel.Delete
   Else
   ThisDrawing.Utility.InitializeUserInput 1, "Move Copy Erase"
   pControl = ThisDrawing.Utility.GetKeyword(vbCr & "请输入操作名[Move(移动)/Copy(复制)/Erase(删除)]:")    ThisDrawing.SendCommand "." & pc & vbCr & "p" & vbCr & vbCr
   End If
End Sub

无痕 · 发表于 2004-7-18 20:49:00

我不喜欢输入层名，我一般就愿意选层实体

copy


(defun c:ssl (/ el)
   (if (setq el (entsel "\n选层实体:"))
         (sssetfirst (setq ss (ssget "x" (list(assoc 8 (entget (car el)))))) ss)
   )
)

运行后，再输入copy，mirror，align，move（当然用简写命令啦，呵呵）。。。好像几乎所以的（没有对话框的）编辑命令都支持预选

雪山飞狐_lzh · 发表于 2004-7-18 21:02:00

^_^，抓VBA的痛脚，PickFrist选择集，VBA实现起来比较变态

快速选取一层的所有对象,进行相应的操作

发表回复

精选推荐