求一个批量建块的程序！
选取上面的图元，自动生成下面的一个个独立的块，块名随机就可以了！
哪位大师有空帮看下！谢谢！
论坛上有，我不记得在那页了，你自己找下(defun c:gk (/ ss lst-ename lst-b x y ss-c)
(vl-load-com)
(setvar "CMDECHO" 0)
;;;选择多线段对象
(setq ss (ssget '((0 . "LWPOLYLINE"))))
;;; 定义将选择集转化为对象图元名列表
(defun ss-enamelst (ss)
(vl-remove-if-not
'(lambda (x) (equal (type x) 'ename))
(mapcar 'cadr (ssnamex SS))
)
)
;;;end defun
;;; 将多线段选择集转化为图元名列表
(setq lst-ename (ss-enamelst ss))
;;; 通过 ssget "WP" 将多线段和多线段内部的对象（可以再加上过滤，过滤掉非园）组成一个表
(setq
lst-b
(mapcar '(lambda (x)
(progn
;;; 多线段端点列表内部窗选
(setqss-c (ssget "WP"
(apply
'append
(mapcar '(lambda (y)
(if (eq (car y) 10)
(list (cdr y))
)
)
(entget x)
)
)
)
)
;;;判断选择集是否存在。也可以加入其它的判断
(if (null ss-c)
(list x)
(append (list x) (ss-enamelst ss-c))
)
) ;end progn
) ;end lambda
lst-ename
)
)
;;;生成无名块并删除原有对象
(mapcar '(lambda (x)
(progn
(entmakenonameblock x (cdr (assoc 10 (entget (car x)))))
(mapcar '(lambda(y)
(vl-cmdf "erase" y "")
)
x
)
)
)
lst-b
)
(prin1)
)
;;;; 图元列表生成无名快
(defun entmakenonameblock (lst pt / i name)
(entmake
(list '(0 . "block") '(2 . "*U") '(70 . 1) (cons 10 pt))
)
(mapcar '(lambda (x) (entmake (cdr (entget x)))) lst)
(setq name (entmake '((0 . "ENDBLK"))))
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
name
) asd19400 发表于 2014-9-4 13:33 static/image/common/back.gif
论坛上有，我不记得在那页了，你自己找下
非常感谢！这个只对多段线有用，还要修改下！谢谢 xiaolong1487 发表于 2014-9-12 18:23 static/image/common/back.gif
非常感谢！这个只对多段线有用，还要修改下！谢谢
自己先闭合撒，一步操作就搞定了 谢谢 ！
解决问题了！ xiaolong1487 发表于 2014-9-29 16:11 static/image/common/back.gif
谢谢 ！
解决问题了！
怎么搞定的，分享下方法 asd19400 发表于 2014-9-29 20:45 static/image/common/back.gif
怎么搞定的，分享下方法
就用的您的方法，谢谢！ (vl-load-com)
(defun Makeunnameblk (entss / boundingbox pois cenpoi)
(defun boundingbox (ss / i ent obj pta ptb dwcorn upcorn ptlist x y)
(setq i 0
dwcorn nil
upcorn nil
)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
(vla-GetBoundingBox obj 'pta 'ptb)
(setq dwcorn (cons (vlax-safearray->list pta) dwcorn))
(setq upcorn (cons (vlax-safearray->list ptb) upcorn))
(setq i (1+ i))
)
(setq ptlist (append dwcorn upcorn))
(setq x (mapcar 'car ptlist))
(setq y (mapcar 'cadr ptlist))
(list (list (apply 'min x) (apply 'min y))
(list (apply 'max x) (apply 'max y))
)
)
(if entss
(progn
(setq pois (boundingbox entss))
(command"cutclip" entss "")
(command"pasteblock" (car pois))
)
)
(command "change" (entlast) "" "P" "la" "0" ""
"change" (entlast) "" "P" "c" "bylayer" "")
;;;;给块重命名
(setq ent (entget (entlast)))
(setq name (cdr (assoc 2 ent))) ;取得块名name
(setq blkname (strcat "K_" (rtos (* (getvar "cdate") 1e8))));给块名设定时间
(command "-rename" "b" name blkname)
(princ (strcat "\n新图块 <" blkname "> 绘制完成. "))
)
(defun c:tt5(/ entss)
(princ "快速建块(块基点为左下点）")
(setq entss (ssget))
(makeunnameblk entss)
(princ)
)
(vl-load-com)
(defun c:bb1(/ co s1 ent)
(setq co (getvar "QAFLAGS"))
(setvar "QAFLAGS" 0)
(princ "快速建块\n请选择对象:")
(if (setq s1 (ssget))
(progn
(vl-cmdf "copybase" (setq pt(getpoint"\n指定块基点:")) s1 "" "pasteblock" pt)
(command "_.ERASE" s1 "")
)
(princ "\n未选择任何对象 *退出*")
)
(setq ent (entget (entlast)))
(setq blkname (cdr (assoc 2 ent)))
(command "change" (entlast) "" "P" "la" "0" ""
"change" (entlast) "" "P" "c" "bylayer" "")
(princ (strcat "\n新图块 <" blkname "> 绘制完成. "))
(setvar "QAFLAGS" co)
(princ)
)
楼上的都是高手啊