《属性表替换属性表》

langjs 发表于 2024-3-6 13:49:06

;;; ===============================================
;;; 《属性表替换属性表》
;;; 作者：langjs    命令:attatt
;;; ===============================================
(defun c:atoa (/ elist ename ent ent1 h i j loop lst lst1 lst2 maxpoint minpoint na name name0 name1 nub p0 pmax pmin pt
            pt1 pt10 pt2 r snap ss ss0 ss1 str w x y
         )
(defun wratt (ent nub str / box ent1 h i j pt pt1 pt10 pt2 w) ; 写属性块
(defun jspt (pt i j)             ; pt相对坐标计算
   (list (+ (car pt) i) (+ (cadr pt) j))
)
(defun sub (ent i str)
   (subst
   (cons i str)
   (assoc i ent)
   ent
   )
)
(setq ent1 ent)
(while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
   (if (= (cdr (assoc 2 ent1)) nub)
   (progn
      (setq pt10 (cdr (assoc 10 ent1)))
      (setq h (cdr (assoc 40 ent1)))
      (setq w 0.7)
      (setq ent1 (sub ent1 41 w))
      (setq ent1 (sub ent1 1 str))
      (if (and
            (setq box (textbox (cdr ent1)))
            (= (cdr (assoc 72 ent1)) 0)
         )
         (progn
         (setq pt1 (jspt pt10 (car (car box)) (* 0.5 (cadr (cadr box)))))
         (setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
         (entmod (sub ent1 1 ""))
         (entmod ent)
         (while (and
                  (ssget "F" (list pt1 pt2) '((0 . "INSERT,LINE")))
                  (> (car pt2) (car pt1))
                  )
            (setq w (- w 0.01))
            (setq ent1 (sub ent1 41 w))
            (setq box (textbox (cdr ent1)))
            (setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
         )
         )
      )
      (entmod ent1)
   )
   )
)
(entmod ent)
)
(defun #err (s)
(setvar "nomutt" 0)
(setvar "osmode" snap)
(if name0
   (redraw name0 4)
)
(setq *error* $orr)
)
(vl-load-com)
(setq $orr *error*)
(setq *error* #err)
(setvar "cmdecho" 0)
(setq snap (getvar "osmode"))
(setvar "nomutt" 1)
(setq ss (ssadd))
(princ "\n选择源属性块样式:")
(if (setq ss0 (ssget ":E:S" (list '(0 . "insert") '(66 . 1))))
(progn
   (setq name0 (ssname ss0 0))
   (setq ent (entget name0))
   (setq na (assoc 2 ent))
   (redraw name0 3)
   (princ "\n框选源属性块：")
   (if (setq ss1 (ssget (list '(0 . "INSERT") na '(66 . 1))))
   (setq ss (ssadd name0 ss1))
   (setq ss (ssadd name0 ss))
   )
   (redraw name0 4)
   (setq lst '())
   (repeat (setq i (sslength ss))
   (setq name (ssname ss (setq i (1- i))))
   (setq ent (entget name))
   (setq ename (entnext name))
   (setq loop t)
   (setq lst1 '())
   (while (and
            ename
            loop
            )
      (setq elist (entget ename))
      (if (= (cdr (assoc 0 elist)) "ATTRIB")
         (progn
         (setq lst1 (cons (list (cdr (assoc 2 elist)) (cdr (assoc 1 elist))) lst1))
         )
         (setq loop nil)
      )
      (setq ename (entnext ename))
   )
   (setq lst (cons (reverse lst1) lst))
   )
   (setq lst (vl-sort lst (function (lambda (x y)
                                    (< (atoi (cadr (car x))) (atoi (cadr (car y))))
                                    )
                        )
            )
   )
   (princ "\n选择目标属性块样式：")
   (if (setq name (car (entsel)))
   (progn
      (vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
      (setq pmax (vlax-safearray->list maxpoint)
            pmin (vlax-safearray->list minpoint)
      )
      (setq x (- (car pmax) (car pmin))
            y (- (cadr pmax) (cadr pmin))
      )
      (setq ent (entget name))
      (setq na (cdr (assoc 1 ent)))
      (setq p0 (cdr (assoc 10 ent)))
      (princ "\n输入插入点：")
      (if (setq pt (getpoint))
         (progn
         (setvar "osmode" 0)
         (princ "\n指定排序方向：")
         (if (setq pt1 (getpoint pt))
            (progn
               (setq r (/ (* 180.0 (angle pt pt1)) pi))
               (cond
               ((< r 45)
                  (setq y 0)
               )
               ((< r 135)
                  (setq x 0)
               )
               ((< r 225)
                  (setq x (* -1 x)
                        y 0
                  )
               )
               ((< r 315)
                  (setq x 0
                        y (* -1 y)
                  )
               )
               (t
                  (setq y 0)
               )
               )
               (foreach lst1 lst
               ((if command-s
                  command-s
                  vl-cmdf
                  ) "copy"
                  name ""
                  p0 pt
               )
               (setq name1 (entlast))
               (setq ent (entget name1))
               (setq ent1 ent)
               (while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
                  (entmod (subst
                           (cons 1 "")
                           (assoc 1 ent1)
                           ent1
                           )
                  )
               )
               (entmod ent)
               (setq ent (entget name1))
               (foreach lst2 lst1
                  (wratt ent (car lst2) (cadr lst2))
               )
               (setq pt (list (+ (car pt) x) (+ (cadr pt) y)))
               )
            )
         )
         )
      )
   )
   )
)
)
(setvar "nomutt" 0)
(setvar "osmode" snap)
(setq *error* $orr)
(princ)
)

weimeng555 发表于 2024-9-13 09:24:28

感谢大师分享，感觉是个好功能，测试没看懂怎么使用以及最终的效果，大师，能否搞个动态图呢

goodt 发表于 2024-3-8 09:27:15

大师，加载后输入命令显未知命令，用不了

p-3-ianlcc 发表于 2024-3-6 14:02:36

再次的感谢大师的分享！
收藏着使用

lxl217114 发表于 2024-3-6 14:17:22

大佬连发三更，非常感谢。

magicheno 发表于 2024-3-6 15:38:03

感谢大佬的分享

spp_wall 发表于 2024-3-6 17:06:12

明经CAD社区's Archiver

《属性表替换属性表》