建块，自动块名称

117g

快速建块，同时将块名称改为文字内容
感谢飞雪大佬提供的源码  （注：块名不能重复）

（整理贴）

飞雪神光

不考虑选择的图形中是否有文字 块名是否重复

1. (defun c:tt (/ km lm-ent-block lm-get-box mid pts ss ss-enlst)
   
2.         (defun lm-Ent-Block (ss name InsertionPoint / lm-active-document lm-model-space lm-vla-list->array block)
   
3.                 (defun lm-active-document nil
   
4.                         (eval (list 'defun 'lm-active-document 'nil (vla-get-activedocument (vlax-get-acad-object))))
   
5.                         (lm-active-document)
   
6.                 )
   
7.                 (defun lm-model-space nil
   
8.                         (eval (list 'defun 'lm-model-space 'nil (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))
   
9.                         (lm-model-space)
   
10.                 )
    
11.                 (defun lm-vla-List->Array (nList arraytype)
    
12.                         (vlax-SafeArray-Fill
    
13.                                 (vlax-Make-SafeArray
    
14.                                         arraytype
    
15.                                         (cons 0 (1- (length nList)))
    
16.                                 )
    
17.                                 nList
    
18.                         )
    
19.                 )
    
20.                 (setq ss (lm-vla-List->Array (mapcar 'vlax-ename->vla-object (vl-remove-if-not '(lambda(arg) (equal (type arg) 'ename)) (mapcar 'cadr (ssnamex ss)))) 9))
    
21.                 (setq block (vla-add (vla-get-Blocks (lm-active-document)) (vlax-3d-point InsertionPoint) name))
    
22.                 (vla-CopyObjects (lm-active-document) ss block)
    
23.                 (vla-InsertBlock (lm-model-space) (vlax-3d-point InsertionPoint) (vla-get-Name block) 1 1 1 0)
    
24.                 (foreach obj (vlax-safearray->list ss) (vla-delete obj))
    
25.                 block
    
26.         )        
    
27.         (defun ss-enlst(ss / enlst)
    
28.                 (cond
    
29.                         ((= (type ss) 'PICKSET)
    
30.                                 (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
    
31.                         )
    
32.                         ((= (type ss) 'LIST)
    
33.                                 (setq enlst (ssadd))
    
34.                                 (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
35.                         )
    
36.                 )
    
37.         )
    
38.         (defun lm-get-box(SS1 / get-enbox get-Extents get-ssbox)
    
39.                 (defun get-ssbox (ss / boxlst maxlst minlst objlst)
    
40.                         (setq objlst (mapcar 'vlax-ename->vla-object (ss-enlst ss)))
    
41.                         (setq boxlst (mapcar 'get-enbox objlst))
    
42.                         (setq minlst (mapcar 'car boxlst))
    
43.                         (setq maxlst (mapcar 'cadr boxlst))
    
44.                         (list
    
45.                                 (apply 'mapcar (cons 'min minlst))
    
46.                                 (apply 'mapcar (cons 'max maxlst))
    
47.                         )
    
48.                 )
    
49.                 (defun get-enbox (obj)
    
50.                         (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
    
51.                         (vla-getboundingbox obj 'Minp 'Maxp)
    
52.                         (mapcar 'vlax-safearray->list (list Minp Maxp))
    
53.                 )
    
54.                 (defun get-Extents(lst);返回点表最大外框两对角点的表
    
55.                         (list
    
56.                                 (apply 'mapcar (cons 'min lst))
    
57.                                 (apply 'mapcar (cons 'max lst))
    
58.                         )
    
59.                 )
    
60.                 (cond
    
61.                         ((= (type SS1) 'PICKSET) (get-ssbox SS1))  ;集
    
62.                         ((= (type SS1) 'ENAME) (get-enbox SS1))    ;图元
    
63.                         ((= (type SS1) 'LIST) (get-Extents SS1))   ;点表
    
64.                         (t nil)
    
65.                 )
    
66.         )
    
67.        (defun get-dxf(en n)
    
68.         (if (not (listp en)) (setq en (entget en)))
    
69.         (cdr (assoc n en))
    
70. )
    
71. (defun Mid (p1 p2)(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)))
    
72.         (setq ss (ssget '()))
    
73.         (foreach ty (ss-enlst ss)
    
74.                 (if(wcmatch (get-dxf ty 0) "*TEXT")
    
75.                         (setq km(get-dxf ty 1))
    
76.                 )
    
77.         )
    
78.         (setq pts (lm-get-box ss))
    
79.         (lm-Ent-Block ss km (apply 'Mid pts))        
    
80.         (princ)
    
81. )

(defun c:tt (/ km lm-ent-block lm-get-box mid pts ss ss-enlst) <br />         (defun lm-Ent-Block (ss name InsertionPoint / lm-active-document lm-model-space lm-vla-list->array block)<br />                 (defun lm-active-document nil <br />                         (eval (list 'defun 'lm-active-document 'nil (vla-get-activedocument (vlax-get-acad-object))))<br />                         (lm-active-document)<br />                 )<br />                 (defun lm-model-space nil<br />                         (eval (list 'defun 'lm-model-space 'nil (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))<br />                         (lm-model-space)<br />                 )<br />                 (defun lm-vla-List->Array (nList arraytype)<br />                         (vlax-SafeArray-Fill<br />                                 (vlax-Make-SafeArray<br />                                         arraytype<br />                                         (cons 0 (1- (length nList)))<br />                                 )<br />                                 nList<br />                         )<br />                 )<br />                 (setq ss (lm-vla-List->Array (mapcar 'vlax-ename->vla-object (vl-remove-if-not '(lambda(arg) (equal (type arg) 'ename)) (mapcar 'cadr (ssnamex ss)))) 9))<br />                 (setq block (vla-add (vla-get-Blocks (lm-active-document)) (vlax-3d-point InsertionPoint) name))<br />                 (vla-CopyObjects (lm-active-document) ss block)<br />                 (vla-InsertBlock (lm-model-space) (vlax-3d-point InsertionPoint) (vla-get-Name block) 1 1 1 0)<br />                 (foreach obj (vlax-safearray->list ss) (vla-delete obj))<br />                 block<br />         )        <br />         (defun ss-enlst(ss / enlst)<br />                 (cond<br />                         ((= (type ss) 'PICKSET)<br />                                 (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />                         )<br />                         ((= (type ss) 'LIST)<br />                                 (setq enlst (ssadd))<br />                                 (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />                         )<br />                 )<br />         )<br />         (defun lm-get-box(SS1 / get-enbox get-Extents get-ssbox)<br />                 (defun get-ssbox (ss / boxlst maxlst minlst objlst)<br />                         (setq objlst (mapcar 'vlax-ename->vla-object (ss-enlst ss)))<br />                         (setq boxlst (mapcar 'get-enbox objlst))<br />                         (setq minlst (mapcar 'car boxlst))<br />                         (setq maxlst (mapcar 'cadr boxlst))<br />                         (list<br />                                 (apply 'mapcar (cons 'min minlst))<br />                                 (apply 'mapcar (cons 'max maxlst))<br />                         )<br />                 )<br />                 (defun get-enbox (obj)<br />                         (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))<br />                         (vla-getboundingbox obj 'Minp 'Maxp)<br />                         (mapcar 'vlax-safearray->list (list Minp Maxp))<br />                 )<br />                 (defun get-Extents(lst);返回点表最大外框两对角点的表<br />                         (list<br />                                 (apply 'mapcar (cons 'min lst))<br />                                 (apply 'mapcar (cons 'max lst))<br />                         )<br />                 )<br />                 (cond<br />                         ((= (type SS1) 'PICKSET) (get-ssbox SS1))  ;集<br />                         ((= (type SS1) 'ENAME) (get-enbox SS1))    ;图元<br />                         ((= (type SS1) 'LIST) (get-Extents SS1))   ;点表<br />                         (t nil)<br />                 )<br />         )<br />        (defun get-dxf(en n)<br />         (if (not (listp en)) (setq en (entget en)))<br />         (cdr (assoc n en))<br /> )<br /> (defun Mid (p1 p2)(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)))<br />         (setq ss (ssget '())) <br />         (foreach ty (ss-enlst ss)<br />                 (if(wcmatch (get-dxf ty 0) "*TEXT")<br />                         (setq km(get-dxf ty 1))<br />                 )<br />         )<br />         (setq pts (lm-get-box ss))<br />         (lm-Ent-Block ss km (apply 'Mid pts))        <br />         (princ)<br /> )

蓝天cayuer

飞雪神光 发表于 2023-9-27 23:34
不考虑选择的图形中是否有文字 块名是否重复

高手 能将生成的块 不含文字 ，但块名是文字吗？

飞雪神光

蓝天cayuer 发表于 2023-9-28 08:03
高手 能将生成的块 不含文字 ，但块名是文字吗？

这里加一句就行了

1. (if(wcmatch (get-dxf ty 0) "*TEXT")
   
2.                         (setq km(get-dxf ty 1) ss(ssdel ty ss))
   
3.                 )

(if(wcmatch (get-dxf ty 0) "*TEXT")<br />                         (setq km(get-dxf ty 1) ss(ssdel ty ss))<br />                 )

蓝天cayuer

飞雪神光 发表于 2023-9-28 08:36
这里加一句就行了

大神 加在哪  我是小白

117g

飞雪神光 发表于 2023-9-27 23:34
不考虑选择的图形中是否有文字 块名是否重复

大佬，图块生成后把原图形也包含进去了，能优化下分离出原选中的图形么？

飞雪神光

117g 发表于 2023-9-28 13:14
大佬，图块生成后把原图形也包含进去了，能优化下分离出原选中的图形么？

这个是块名重复造成的 改下文字就可以了

飞雪神光

蓝天cayuer 发表于 2023-9-28 12:44
大神 加在哪  我是小白

1. (defun c:tt (/ km lm-ent-block lm-get-box mid pts ss ss-enlst)
   
2.         (defun lm-Ent-Block (ss name InsertionPoint / lm-active-document lm-model-space lm-vla-list->array block)
   
3.                 (defun lm-active-document nil
   
4.                         (eval (list 'defun 'lm-active-document 'nil (vla-get-activedocument (vlax-get-acad-object))))
   
5.                         (lm-active-document)
   
6.                 )
   
7.                 (defun lm-model-space nil
   
8.                         (eval (list 'defun 'lm-model-space 'nil (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))
   
9.                         (lm-model-space)
   
10.                 )
    
11.                 (defun lm-vla-List->Array (nList arraytype)
    
12.                         (vlax-SafeArray-Fill
    
13.                                 (vlax-Make-SafeArray
    
14.                                         arraytype
    
15.                                         (cons 0 (1- (length nList)))
    
16.                                 )
    
17.                                 nList
    
18.                         )
    
19.                 )
    
20.                 (setq ss (lm-vla-List->Array (mapcar 'vlax-ename->vla-object (vl-remove-if-not '(lambda(arg) (equal (type arg) 'ename)) (mapcar 'cadr (ssnamex ss)))) 9))
    
21.                 (setq block (vla-add (vla-get-Blocks (lm-active-document)) (vlax-3d-point InsertionPoint) name))
    
22.                 (vla-CopyObjects (lm-active-document) ss block)
    
23.                 (vla-InsertBlock (lm-model-space) (vlax-3d-point InsertionPoint) (vla-get-Name block) 1 1 1 0)
    
24.                 (foreach obj (vlax-safearray->list ss) (vla-delete obj))
    
25.                 block
    
26.         )        
    
27.         (defun ss-enlst(ss / enlst)
    
28.                 (cond
    
29.                         ((= (type ss) 'PICKSET)
    
30.                                 (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
    
31.                         )
    
32.                         ((= (type ss) 'LIST)
    
33.                                 (setq enlst (ssadd))
    
34.                                 (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
35.                         )
    
36.                 )
    
37.         )
    
38.         (defun lm-get-box(SS1 / get-enbox get-Extents get-ssbox)
    
39.                 (defun get-ssbox (ss / boxlst maxlst minlst objlst)
    
40.                         (setq objlst (mapcar 'vlax-ename->vla-object (ss-enlst ss)))
    
41.                         (setq boxlst (mapcar 'get-enbox objlst))
    
42.                         (setq minlst (mapcar 'car boxlst))
    
43.                         (setq maxlst (mapcar 'cadr boxlst))
    
44.                         (list
    
45.                                 (apply 'mapcar (cons 'min minlst))
    
46.                                 (apply 'mapcar (cons 'max maxlst))
    
47.                         )
    
48.                 )
    
49.                 (defun get-enbox (obj)
    
50.                         (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
    
51.                         (vla-getboundingbox obj 'Minp 'Maxp)
    
52.                         (mapcar 'vlax-safearray->list (list Minp Maxp))
    
53.                 )
    
54.                 (defun get-Extents(lst);返回点表最大外框两对角点的表
    
55.                         (list
    
56.                                 (apply 'mapcar (cons 'min lst))
    
57.                                 (apply 'mapcar (cons 'max lst))
    
58.                         )
    
59.                 )
    
60.                 (cond
    
61.                         ((= (type SS1) 'PICKSET) (get-ssbox SS1))  ;集
    
62.                         ((= (type SS1) 'ENAME) (get-enbox SS1))    ;图元
    
63.                         ((= (type SS1) 'LIST) (get-Extents SS1))   ;点表
    
64.                         (t nil)
    
65.                 )
    
66.         )
    
67.         (defun get-dxf(en n)
    
68.                 (if (not (listp en)) (setq en (entget en)))
    
69.                 (cdr (assoc n en))
    
70.         )
    
71.         (defun Mid (p1 p2)(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)))
    
72.         (setq ss (ssget '()))
    
73.         (foreach ty (ss-enlst ss)
    
74.                 (if(wcmatch (get-dxf ty 0) "*TEXT")
    
75.                         (setq km(get-dxf ty 1) ss(ssdel ty ss))
    
76.                 )
    
77.         )
    
78.         (setq pts (lm-get-box ss))
    
79.         (lm-Ent-Block ss km (apply 'Mid pts))        
    
80.         (princ)
    
81. )

(defun c:tt (/ km lm-ent-block lm-get-box mid pts ss ss-enlst) <br />         (defun lm-Ent-Block (ss name InsertionPoint / lm-active-document lm-model-space lm-vla-list->array block)<br />                 (defun lm-active-document nil <br />                         (eval (list 'defun 'lm-active-document 'nil (vla-get-activedocument (vlax-get-acad-object))))<br />                         (lm-active-document)<br />                 )<br />                 (defun lm-model-space nil<br />                         (eval (list 'defun 'lm-model-space 'nil (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))))<br />                         (lm-model-space)<br />                 )<br />                 (defun lm-vla-List->Array (nList arraytype)<br />                         (vlax-SafeArray-Fill<br />                                 (vlax-Make-SafeArray<br />                                         arraytype<br />                                         (cons 0 (1- (length nList)))<br />                                 )<br />                                 nList<br />                         )<br />                 )<br />                 (setq ss (lm-vla-List->Array (mapcar 'vlax-ename->vla-object (vl-remove-if-not '(lambda(arg) (equal (type arg) 'ename)) (mapcar 'cadr (ssnamex ss)))) 9))<br />                 (setq block (vla-add (vla-get-Blocks (lm-active-document)) (vlax-3d-point InsertionPoint) name))<br />                 (vla-CopyObjects (lm-active-document) ss block)<br />                 (vla-InsertBlock (lm-model-space) (vlax-3d-point InsertionPoint) (vla-get-Name block) 1 1 1 0)<br />                 (foreach obj (vlax-safearray->list ss) (vla-delete obj))<br />                 block<br />         )        <br />         (defun ss-enlst(ss / enlst)<br />                 (cond<br />                         ((= (type ss) 'PICKSET)<br />                                 (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />                         )<br />                         ((= (type ss) 'LIST)<br />                                 (setq enlst (ssadd))<br />                                 (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />                         )<br />                 )<br />         )<br />         (defun lm-get-box(SS1 / get-enbox get-Extents get-ssbox)<br />                 (defun get-ssbox (ss / boxlst maxlst minlst objlst)<br />                         (setq objlst (mapcar 'vlax-ename->vla-object (ss-enlst ss)))<br />                         (setq boxlst (mapcar 'get-enbox objlst))<br />                         (setq minlst (mapcar 'car boxlst))<br />                         (setq maxlst (mapcar 'cadr boxlst))<br />                         (list<br />                                 (apply 'mapcar (cons 'min minlst))<br />                                 (apply 'mapcar (cons 'max maxlst))<br />                         )<br />                 )<br />                 (defun get-enbox (obj)<br />                         (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))<br />                         (vla-getboundingbox obj 'Minp 'Maxp)<br />                         (mapcar 'vlax-safearray->list (list Minp Maxp))<br />                 )<br />                 (defun get-Extents(lst);返回点表最大外框两对角点的表<br />                         (list<br />                                 (apply 'mapcar (cons 'min lst))<br />                                 (apply 'mapcar (cons 'max lst))<br />                         )<br />                 )<br />                 (cond<br />                         ((= (type SS1) 'PICKSET) (get-ssbox SS1))  ;集<br />                         ((= (type SS1) 'ENAME) (get-enbox SS1))    ;图元<br />                         ((= (type SS1) 'LIST) (get-Extents SS1))   ;点表<br />                         (t nil)<br />                 )<br />         )<br />         (defun get-dxf(en n)<br />                 (if (not (listp en)) (setq en (entget en)))<br />                 (cdr (assoc n en))<br />         )<br />         (defun Mid (p1 p2)(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)))<br />         (setq ss (ssget '())) <br />         (foreach ty (ss-enlst ss)<br />                 (if(wcmatch (get-dxf ty 0) "*TEXT")<br />                         (setq km(get-dxf ty 1) ss(ssdel ty ss))<br />                 )<br />         )<br />         (setq pts (lm-get-box ss))<br />         (lm-Ent-Block ss km (apply 'Mid pts))        <br />         (princ)<br /> )

蓝天cayuer

运行后提示以下
错误: Automation 错误。 调用方法 SetObjectId (接口 IAcadBaseObject) 失败

117g

蓝天cayuer 发表于 2023-9-28 14:27
运行后提示以下
错误: Automation 错误。 调用方法 SetObjectId (接口 IAcadBaseObject) 失败

没有，插件能正常运行 就是需要块名不能重复，会乱