社区 › AutoCAD基础应用 › 程序求修改

孙海波 发表于 2023-4-8 20:49:30

程序求修改

我在站内找到一个程序，可以实现框选范围内的块全部变为匿名块，但是有一个问题，只要遇到属性块就不行了，希望大家修改。
程序附后：



(defun c:gk (/ ss lst-ename lst-b x y ss-c)
(vl-load-com)
(setvar "CMDECHO" 0)
;;;选择框选范围内的所有块
(setq ss (ssget '((0 . "INSERT"))))
;;; 定义将选择集转化为对象图元名列表
(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
)

pzweng 发表于 2023-4-18 14:27:31

(defun c:gk (/ ss lst-ename lst-b x y ss-c)
(vl-load-com)
(setvar "CMDECHO" 0)
;;;选择框选范围内的所有块
(setq ss (ssget '((0 . "INSERT"))))
;;; 定义将选择集转化为对象图元名列表
(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
;;; 多线段端点列表内部窗选
                  (setq        ss-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)
(entmake '((0 . "SEQEND")))
(setq name (entmake '((0 . "ENDBLK"))))
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
name
)

孙海波 发表于 2023-7-17 14:25:39

pzweng 发表于 2023-4-18 14:27
(defun c:gk (/ ss lst-ename lst-b x y ss-c)
(vl-load-com)
(setvar "CMDECHO" 0)


不行，属性块里面的文字不见了

ssyfeng 发表于 2023-7-17 15:17:28

如果有问题，可以上传dwg文件测试

查看完整版本: 程序求修改