建块，自动块名称

117g 发表于 2023-9-27 22:13:56

本帖最后由 117g 于 2023-12-12 21:35 编辑

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

（整理贴）

飞雪神光 发表于 2023-9-27 23:34:26

本帖最后由飞雪神光于 2023-9-27 23:36 编辑

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

蓝天cayuer 发表于 2023-9-28 08:03:56

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

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

飞雪神光 发表于 2023-9-28 08:36:32

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

这里加一句就行了(if(wcmatch (get-dxf ty 0) "*TEXT")
(setq km(get-dxf ty 1) ss(ssdel ty ss))
)

蓝天cayuer 发表于 2023-9-28 12:44:17

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

大神加在哪我是小白

117g 发表于 2023-9-28 13:14:23

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

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

飞雪神光 发表于 2023-9-28 13:27:46

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

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

飞雪神光 发表于 2023-9-28 13:28:48

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

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

蓝天cayuer 发表于 2023-9-28 14:27:27

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

117g 发表于 2023-11-28 10:55:58

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

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

页: [1] 2

明经CAD社区's Archiver

建块，自动块名称