求一个批量建块的程序！

xiaolong1487

选取上面的图元，自动生成下面的一个个独立的块，块名随机就可以了！




哪位大师有空帮看下！谢谢！

asd19400

论坛上有，我不记得在那页了，你自己找下

2. (defun c:gk (/ ss lst-ename lst-b x y ss-c)
   
3.   (vl-load-com)
   
4.   (setvar "CMDECHO" 0)
   
5. ;;;选择多线段对象
   
6.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
   
7. ;;; 定义将选择集转化为对象图元名列表
   
8.   (defun ss-enamelst (ss)
   
9.     (vl-remove-if-not
   
10.       '(lambda (x) (equal (type x) 'ename))
    
11.       (mapcar 'cadr (ssnamex SS))
    
12.     )
    
13.   )
    
14. ;;;end defun
    
15. 
    
16. ;;; 将多线段选择集转化为图元名列表
    
17.   (setq lst-ename (ss-enamelst ss))
    
18. ;;; 通过 ssget "WP" 将多线段和多线段内部的对象（可以再加上过滤，过滤掉非园）组成一个表
    
19.   (setq
    
20.     lst-b
    
21.      (mapcar '(lambda (x)
    
22.     (progn
    
23. ;;; 多线段端点列表内部窗选
    
24.       (setq  ss-c (ssget "WP"
    
25.             (apply
    
26.               'append
    
27.               (mapcar '(lambda (y)
    
28.              (if (eq (car y) 10)
    
29.                (list (cdr y))
    
30.              )
    
31.                  )
    
32.                 (entget x)
    
33.               )
    
34.             )
    
35.            )
    
36.       )
    
37. ;;;判断选择集是否存在。也可以加入其它的判断
    
38.       (if (null ss-c)
    
39.         (list x)
    
40.         (append (list x) (ss-enamelst ss-c))
    
41.       )
    
42.     )      ;end progn
    
43.         )        ;end lambda
    
44.        lst-ename
    
45.      )
    
46.   )
    
47. ;;;生成无名块并删除原有对象
    
48.   (mapcar '(lambda (x)
    
49.        (progn
    
50.          (entmakenonameblock x (cdr (assoc 10 (entget (car x)))))
    
51.          (mapcar '(lambda  (y)
    
52.         (vl-cmdf "erase" y "")
    
53.       )
    
54.            x
    
55.          )
    
56.        )
    
57.      )
    
58.     lst-b
    
59.   )
    
60. 
    
61. 
    
62.   (prin1)
    
63. )
    
64. ;;;; 图元列表生成无名快
    
65. (defun entmakenonameblock (lst pt / i name)
    
66.   (entmake
    
67.     (list '(0 . "block") '(2 . "*U") '(70 . 1) (cons 10 pt))
    
68.   )
    
69.   (mapcar '(lambda (x) (entmake (cdr (entget x)))) lst)
    
70.   (setq name (entmake '((0 . "ENDBLK"))))
    
71.   (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
    
72.   name
    
73. )

(defun c:gk (/ ss lst-ename lst-b x y ss-c)<br />   (vl-load-com)<br />   (setvar "CMDECHO" 0)<br /> ;;;选择多线段对象<br />   (setq ss (ssget '((0 . "LWPOLYLINE"))))<br /> ;;; 定义将选择集转化为对象图元名列表<br />   (defun ss-enamelst (ss)<br />     (vl-remove-if-not<br />       '(lambda (x) (equal (type x) 'ename))<br />       (mapcar 'cadr (ssnamex SS))<br />     )<br />   )<br /> ;;;end defun<br /> <br /> ;;; 将多线段选择集转化为图元名列表<br />   (setq lst-ename (ss-enamelst ss))<br /> ;;; 通过 ssget "WP" 将多线段和多线段内部的对象（可以再加上过滤，过滤掉非园）组成一个表<br />   (setq<br />     lst-b<br />      (mapcar '(lambda (x)<br />     (progn<br /> ;;; 多线段端点列表内部窗选<br />       (setq  ss-c (ssget "WP"<br />             (apply<br />               'append<br />               (mapcar '(lambda (y)<br />              (if (eq (car y) 10)<br />                (list (cdr y))<br />              )<br />                  )<br />                 (entget x)<br />               )<br />             )<br />            )<br />       )<br /> ;;;判断选择集是否存在。也可以加入其它的判断<br />       (if (null ss-c)<br />         (list x)<br />         (append (list x) (ss-enamelst ss-c))<br />       )<br />     )      ;end progn<br />         )        ;end lambda<br />        lst-ename<br />      )<br />   )<br /> ;;;生成无名块并删除原有对象<br />   (mapcar '(lambda (x)<br />        (progn<br />          (entmakenonameblock x (cdr (assoc 10 (entget (car x)))))<br />          (mapcar '(lambda  (y)<br />         (vl-cmdf "erase" y "")<br />       )<br />            x<br />          )<br />        )<br />      )<br />     lst-b<br />   )<br /> <br /> <br />   (prin1)<br /> )<br /> ;;;; 图元列表生成无名快<br /> (defun entmakenonameblock (lst pt / i name)<br />   (entmake<br />     (list '(0 . "block") '(2 . "*U") '(70 . 1) (cons 10 pt))<br />   )<br />   (mapcar '(lambda (x) (entmake (cdr (entget x)))) lst)<br />   (setq name (entmake '((0 . "ENDBLK"))))<br />   (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))<br />   name<br /> )

xiaolong1487

asd19400 发表于 2014-9-4 13:33
论坛上有，我不记得在那页了，你自己找下

非常感谢！这个只对多段线有用，还要修改下！谢谢

asd19400

xiaolong1487 发表于 2014-9-12 18:23
非常感谢！这个只对多段线有用，还要修改下！谢谢

自己先闭合撒，一步操作就搞定了

xiaolong1487

谢谢 ！
解决问题了！

asd19400

xiaolong1487 发表于 2014-9-29 16:11
谢谢 ！
解决问题了！

怎么搞定的，分享下方法

xiaolong1487

asd19400 发表于 2014-9-29 20:45
怎么搞定的，分享下方法

就用的您的方法，谢谢！

ucuc2003

(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)
)

ucuc2003

(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)
)

wangshuping42

楼上的都是高手啊