社区 › 源码共享 › 快速选取一层的所有对象,进行相应的操作

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

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

本帖最后由 作者 于 2004-5-19 9:50:44 编辑 <br /><br /> Sub QSelLayerControl()<BR>'程序功能:快速选取一层的所有对象,进行相应的操作<BR>                       Dim i       As AcadEntity<BR>                       Dim ss As AcadSelectionSet<BR>                       Dim ft(0) As Integer, fd(0)<BR>                       Dim pLayer As String<BR>                       Dim pControl As String<BR>                       pLayer = ThisDrawing.Utility.GetString(0, vbCrlLf &amp; "请输入层名:")<BR>                       ft(0) = 8: fd(0) = pLayer<BR>                       Set ss = ThisDrawing.ActiveSelectionSet<BR>                       ss.Clear<BR>                       ss.Select acSelectionSetAll, , , ft, fd<BR>                       If ss.Count = 0 Then<BR>                                                       ss.Delete<BR>                                                       ThisDrawing.Utility.Prompt "层内没有对象或层不存在!"<BR>                       Else<BR>                                                       ThisDrawing.Utility.InitializeUserInput 1, "Move Copy Erase"<BR>                                                       pControl = ThisDrawing.Utility.GetKeyword(vbCr &amp; "请输入操作名:")<BR>                                                       ThisDrawing.SendCommand "." &amp; pControl &amp; vbCr &amp; "p" &amp; vbCr &amp; vbCr<BR>                       End If<BR>'附:将下列代码Copy到acad200?doc.lsp中,执行命令QSLC<BR>'                       (defun C:QSLC()<BR>'                       (setvar "cmdecho" 0)<BR>'                       (command "-vbarun" "qsellayercontrol")<BR>'                       (setvar "cmdecho" 1)<BR>'                       (princ)<BR>'                       )<BR>End Sub<BR>

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

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

修改以下看看



Sub qselect()<BR>Dim tsel As AcadSelectionSet<BR>Dim entry As AcadEntity<BR>Dim tpic As Variant<BR>Dim layerstr As String<BR>On Error Resume Next<BR>Set tsel = ThisDrawing.SelectionSets("topirolss")<BR>If Err Then<BR>Err.Clear<BR>Set tsel = ThisDrawing.SelectionSets.Add("topirolss")<BR>tsel.Clear<BR>End If<BR>ThisDrawing.Utility.GetEntity entry, tpic, "选择实体："


If Err Then<BR>Err.Clear<BR>Exit Sub<BR>End If<BR>layerstr = entry.Layer<BR>               Dim FilterType(0) As Integer<BR>               Dim FilterData(0) As Variant<BR>               FilterType(0) = 8<BR>               FilterData(0) = layerstr<BR>               tsel.Select acSelectionSetAll, , , FilterType, FilterData<BR>               tsel.Highlight (True)<BR>               If tsel.Count = 0 Then<BR>               tsel.Delete<BR>               Else<BR>               ThisDrawing.Utility.InitializeUserInput 1, "Move Copy Erase"<BR>               pControl = ThisDrawing.Utility.GetKeyword(vbCr &amp; "请输入操作名:")               ThisDrawing.SendCommand "." &amp; pc &amp; vbCr &amp; "p" &amp; vbCr &amp; vbCr<BR>               End If<BR>End Sub

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

我不喜欢输入层名，我一般就愿意选层实体(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实现起来比较变 态

查看完整版本: 快速选取一层的所有对象,进行相应的操作