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

雪山飞狐_lzh

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 C:QSLC()
' (setvar "cmdecho" 0)
' (command "-vbarun" "qsellayercontrol")
' (setvar "cmdecho" 1)
' (princ)
' )
End Sub

woshiyu121

你好！


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

雪山飞狐_lzh

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

gjliang

修改以下看看 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

无痕

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

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

(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

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