[编程申请]：自动整合称快的lisp

逐月飞鸿

自动整合称快的lisp
在修改图纸的时候，常常需要图中的一些元素一块移动，有没有这样的lisp，在选中要一起移动或修改的物体后，执行一个命令，那么选中的物体就自动整合成一个块（而少了写块的一系列过程），这样就给以后这些元素（如：线段，直线，文字……）再次修改或移动带来很大的方便。诚求高手编写！

dandee

group就是这样的命令，
ctrl+h 快捷键，可以开关group
不过，group也有个缺点要自己起group名字，
我曾经写过这样一段程序，
gc --->选中一些物体，自动生成group.其名字是随机的。
gd--->在该group里添加元素
gm-->把group砸掉

(defun c:gc(  )
(princ "creat a group:")
(setq ss (ssget))
(setq s (getvar "DATE"))
(vl-cmdf "group" "c" (rtos (* 86400.0 (- s (fix s))) 2 0) "*object" ss "")
(princ "Group Name:")(princ (rtos (* 86400.0 (- s (fix s))) 2 0))
(setq ss nil)
(princ "\n   ")
(princ))

(defun c:gd(  / grpss grpssn grplist nm)
(setq grpss (entget (cdr (assoc 330 (entget  (car (entsel)))    ))   ))
(if (= "GROUP" (cdr (assoc 0 grpss)))
(progn
(setq grpssn (cons 350  (cdr (assoc -1 grpss))))
(setq grplist (entget (cdr (assoc 330 grpss   ))))
(setq nm  (- (- (length grplist)   (length (member grpssn grplist))  ) 1))
(princ "Group Name:")(princ (cdr (nth nm grplist)) )
(princ "-->>")

(vl-cmdf "group" "a" (cdr (nth nm grplist))  pause)


)(princ "no Group")
)

(princ "\n   ")
(princ))

(defun c:gm( / grpss grpssn grplist nm)
(setq grpss (entget (cdr (assoc 330 (entget  (car (entsel)))    ))   ))
(if (= "GROUP" (cdr (assoc 0 grpss)))
(progn
(setq grpssn (cons 350  (cdr (assoc -1 grpss))))
(setq grplist (entget (cdr (assoc 330 grpss   ))))
(setq nm  (- (- (length grplist)   (length (member grpssn grplist))  ) 1))
;(princ "Select  new  object  to")
(princ "Group Name:")(princ (cdr (nth nm grplist)) )
(princ "-->> Explode !")
(vl-cmdf "group" "e"  (cdr (nth nm grplist)) )
)(princ "no Group")
)

(princ "\n   ")
(princ))

逐月飞鸿

谢谢，很是好用。多谢了～～而且gm如果也支持先选择物体也能执行就更好了····

sany

group可以使用无名组，就不用担心组名的重复了。
(vl-cmdf "-group"
                 "create"
                 "*"
                 ""
                 (ssget )
                  ""
        )

huiling6868

命令gd有什么用怎么用.

dandee

gd 含义就是group里的add的选项，只是简化了，去掉了输入group名字的那一步。

啵浪鼓

简单点的建群组程序：
ag：选中物体建立D群组
gg：加入新的物体进入D群组
eg：删除eg群组内容

(defun c:ag ()
(prompt "Create 'D' Group ")
(setq s(ssget))
(command "group" "c" "D" "" s "")
(princ)
)

(defun c:gg ()
(prompt "Join 'D' Group ")
(setq s(ssget))
(command "group" "add" "D" s "")
(princ)
)

(defun c:eg ()
(prompt "Erase 'D' Group ")
(command "erase" "group" "D" "")
(princ)
)

狂刀

楼上的，'D' Group　中的＂ｄ＂可不好得哦，总不能让人家自己填组名吧？

楼主的要求，可以用定点复制，原点粘贴成块的方法．（如果不在乎插入点，直接ｃｔｒｌ＋ｃ）

啵浪鼓

如果档案内没有D的群组，第一次使用先用ag创建D群组，之后档案内存在D的群组后就可以用gg来添加新的物体进D群组，无须用户输入组名。。。

c7242865

不同图层的元素组成一个Group后，如果有个元素图层关闭或冻结，则无法将该Group的所有元素，进行搬移、复制，删除等命令。
请问有替代方法吗？

zh_6531394

非常好用,省去了每次出现对话框,写组名的麻烦

dandee

最初由 逐月飞鸿 发布
[B]谢谢，很是好用。多谢了～～而且gm如果也支持先选择物体也能执行就更好了···· [/B]

As u wish...

(defun c:gm()
(setq grpss (entget (cdr (assoc 330 (entget  (car (entsel)))    ))   ))
(if (= "GROUP" (cdr (assoc 0 grpss)))
(progn
(show-gr grpss 3)(getkword "\n")

(setq grpssn (cons 350  (cdr (assoc -1 grpss))))
(setq grplist (entget (cdr (assoc 330 grpss   ))))
(setq nm  (- (- (length grplist)   (length (member grpssn grplist))  ) 1))

(princ "Group Name:")(princ (cdr (nth nm grplist)) )
(princ "-->> Explode !")
(show-gr grpss 4)
(vl-cmdf "group"  "e"  (cdr (nth nm grplist)) pause )

)(princ "no Group")
)

(princ "\n   ")
(princ))


(defun show-gr(grpss grpn / grtable grtt)
(setq grtt t)  (setq grtable grpss)
(while grtt
(setq grtt (dxf grtable 340))
(if grtt (progn (redraw grtt grpn)
(setq grtable (vl-remove (vl-list* 340 grtt ) grtable)) ))
)
)

(defun dxf(ent i)(if (= (type ent) 'ename)(setq ent (entget ent)))(cdr (assoc i ent)))


再添个
命令为ge ,-->移除group里某个元素  

(defun c:ge()
(princ "Group-->")
(setq grpss (entget (cdr (assoc 330 (entget  (car (entsel)))    ))   ))
(if (= "GROUP" (cdr (assoc 0 grpss)))
(progn
(setq grpssn (cons 350  (cdr (assoc -1 grpss))))
(setq grplist (entget (cdr (assoc 330 grpss   ))))
(setq nm  (- (- (length grplist)   (length (member grpssn grplist))  ) 1))
(princ "Group Name:")(princ (cdr (nth nm grplist)) )
(princ "-->>")
(vl-cmdf "group" "r" (cdr (nth nm grplist))  pause)
)(princ "no Group")
)
(princ "\n   ")
(princ))

另外:
各位如果用acad2006 的话，可以把这些代码完全整合进group.
用2006的新功能--> 选项菜单 ， 只需输入一个命令， 其他由 mouse搞定

aeo

找找"陌生人"的贴

zxdvip

2楼的程序很好,避免了反复命名组.

雨箭风刀

可以考虑 ctrl＋x； shift＋ctrl＋v 做块