找到一个狂刀的拷贝块内实体程序
本帖最后由 42142 于 2014-10-22 16:36 编辑;放在这里,希望作者不要生气
;| blkssc,knkb (拷贝块内实体)----by lxx.2007.12
函数 c:blkssc 或 c:knkb (块内拷贝)
功能: 1.点选要编辑的块，自动亮显块内实体
2.选择要删除的块内实体（支持框选）。选中后取消亮显，再次选择恢复亮显（亮显的即块内实体）
3.回车或空选退出编辑状态
4.已设出错处理，中途退出恢复编辑前状态.
|;
(defun c:knkb ()(c:blkssc)) ;; knsc = 块内删除.
(defun c:blkssc (/ *ERROR* *MYERR BLKN E EEE NPT OLDERR PAUSE SS SS2 SSB SSN SSR SSS SSS2 X ssx)
(princ "\n knkb=拷贝块内实体 by lxx.2008.2")
(defun *myerr (msg)(if sss2 (progn(command ".undo" "e")(command ".u")))(setq *error* olderr)(princ))
(setq olderr *error*
*error* *myerr)
(princ "\n 选择要局部拷贝的块（可多选）：")
(if (setq ss (ssget '((0 . "INSERT"))))
(progn
(setq e(ssname ss 0)
blkn (cdr (assoc 2 (entget e)))
)
(command ".undo" "be")
(setvar "qaflags" 1)
(command ".explode" ss "")
(setq ss2 (ssget "p"))
(setq sss2 (xss2lst ss2))
(mapcar '(lambda (x) (redraw x 3)) sss2)
(princ "\n 选择要拷贝的块内实体,亮显为块内保留实体:")
(while (setq ssa (ssget ":S"))
(mapcar '(lambda (x)
(if (and (ssmemb x ss2) (member x ssr))
(progn (redraw x 3)
(setq ssr (vl-remove x ssr))
)
(if (ssmemb x ss2)
(progn (redraw x 4)
(setq ssr (cons x ssr))
)
)
)
)
(xss2lst ssa)
)
)
(setq ssx (mapcar 'entget ssr))
(command ".u")
;;; (setq ;npt (getpoint "\n 拷贝基点：")
;;; ;npt2 (getpoint "\n 拷贝到：")
;;; )
(setq eee (entlast)
ssn (ssadd))
(mapcar 'entmake ssx)
;;; (setq eee(entnext eee))
(while (setq eee(entnext eee))
(ssadd eee ssn)
)
;;; (command ".move" ssn "" npt pause)
;;; (setq rlst (mapcar '(lambda (x) (vl-position x sss2)) ssr))
;;; (setq i -1)
;;; (vlax-for x (vla-item
;;; (vla-get-blocks
;;; (vla-get-activedocument (vlax-get-acad-object))
;;; )
;;; blkn
;;; )
;;; (setq i (1+ i))
;;; (if (member i rlst)
;;; (vla-delete x)
;;; )
;;; )
;;; (setq ssb (ssget "x" (list (cons 0 "INSERT") (cons 2 blkn)))
;;; sssb (xss2lst ssb)
;;; )
;;; (mapcar 'entupd sssb)
(command ".undo" "e")
;;; ssb
)
)
(if ssn
;(sssetfirst ssn ssn)
(command ".move" ssn "")
)
)
;; v1.1
(defun xss2lst (ss / i lst)
(setq i (sslength ss))
(repeat i
(setq lst (cons (ssname ss (setq i (1- i))) lst))
)
)
(princ "\n knkb=拷贝块内实体 by lxx.2008.2")
感谢分享程序! 果然不错... 感谢分享程序! (defun c:knkb ()(c:blkssc) (setvar "qaflags" 0)) ;; knsc = 块内删除.
主命令须换成这个，把变量还原，不然会对一些人造成很大的麻烦的哦。另外这个使用时有一个小BUG，就是有时会把原块给全炸开了，这也是这个qaflags变量闹的，但这里提块里面的东西又不得不用它，所以看哪位有时间的童鞋修正一下就好了。总体来说，这个程序思路还是不错的。 我感觉其实就是炸块， 实质就是把块炸开。不过 确实是个好办法 真好用,但老有BUG.会把原来的块炸开,这样就得不得不偿失了 本帖最后由 hooboxu 于 2014-10-30 23:13 编辑
哦.不好意思不是炸开,中途取消后应该是留着原地了.误以为是炸开的.再试用看看.
还有想提个建议,能不能把亮显的改是不复制出来的. 亮显的是复制出来.感觉好像没被选中的反被复制了,有点不习惯啊.有没有同感的人呢?
谢谢分享.好赞 还是有BUG..原块会炸散.不太稳定,求修复
不是很稳定啊
页:
[1]
2