一个用来刷相同的刷子源码

langjs

;;; 　　　      《相同刷》v1.0
;;; ========================================================
;;; 功能：将目标文字内容刷成源文字内容，将目标圆大小刷成源圆
;;;       的大小，将目标块刷成源块一样，将目标线、圆、圆弧、
;;;       多段线等刷成源多段线相同的线宽。源为线、尺寸、填充
;;;       圆弧则目标特性匹配
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集
;;; 作者：langjs     qq:59509100        日期:2011年12月19日
;;; ========================================================
(defun c:xts (/ ent i lst mame na pt ss tp ty u1 u2 u3 u4 uu)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (defun #err (s)
    (redraw mame 4)
    (setvar "nomutt" 0)
    (command ".UNDO" "E")
    (setq *error* $orr)
    (princ)
  )
  (setq $orr *error*)
  (setq *error* #err)
  (command ".UNDO" "BE")
  (while (not (and
  (setq mame (car (entsel "\n选择源对象:")))
  (setq ent (entget mame))
  (setq ty (cdr (assoc 0 ent)))
  (member ty '("TEXT" "MTEXT"
    "LWPOLYLINE" "CIRCLE"
    "INSERT" "LINE"
    "ARC" "HATCH"
    "DIMENSION"
   )
  )
       )
  )
    (if (= 52 (getvar "errno"))
      (vl-exit-with-error "")
    )
  )
  (redraw mame 3)
  (setvar "nomutt" 1)
  (if (member ty '("TEXT" "MTEXT"))
    (progn
      (setq uu (cdr (assoc 1 ent)))
      (princ "\n选择目标对象:<文字相同>")
      (setq ss (ssget '((0 . "TEXT,MTEXT"))))
      (repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
    (cons 1 uu)
    (assoc 1 ent)
    ent
  )
)
      )
    )
  )
  (if (= ty "CIRCLE")
    (progn
      (setq uu (cdr (assoc 40 ent)))
      (princ "\n选择目标对象:<圆相同>")
      (setq ss (ssget '((0 . "CIRCLE"))))
      (repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
    (cons 40 uu)
    (assoc 40 ent)
    ent
  )
)
      )
    )
  )
  (if (= ty "INSERT")
    (progn
      (setq u1 (cdr (assoc 2 ent)))
      (setq u2 (cdr (assoc 41 ent)))
      (setq u3 (cdr (assoc 42 ent)))
      (setq u4 (* (/ (cdr (assoc 50 ent)) pi) 180))
      (princ "\n选择目标对象:<块相同>")
      (setq ss (ssget '((0 . "INSERT"))))
      (repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(setq lst (cons (cdr (assoc 10 ent)) lst))
      )
      (command "erase" ss "")
      (repeat (setq i (length lst))
(setq pt (nth (setq i (1- i))
        lst
   )
)
(command "insert" u1 pt u2 u3 u4)
      )
    )
  )
  (if (= ty "LWPOLYLINE")
    (progn
      (if (setq uu (cdr (assoc 43 ent)))
(princ)
(setq uu (cdr (assoc 40 ent)))
      )
      (princ "\n选择目标对象:<线宽相同>")
      (setq ss (ssget '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))
      (repeat (setq i (sslength ss))
(setq na (ssname ss (setq i (1- i))))
(setq ent (entget na))
(setq tp (cdr (assoc 0 ent)))
(if (member tp '("LINE" "ARC"))
   (command "pedit" na "Y" "w" uu "x")
)
(if (member tp '("POLYLINE" "LWPOLYLINE"))
   (command "pedit" na "w" uu "x")
)
(if (= tp "CIRCLE")
   (progn
     (setq u1 (cdr (assoc 10 ent)))
     (setq u2 (cdr (assoc 40 ent)))
     (setq u3 (- (* u2 2) uu))
     (setq u4 (+ (* u2 2) uu))
     (command "donut" u3 u4 u1 "")
     (entdel na)
   )
)
      )
    )
  )
  (if (member ty '("LINE" "ARC"
        "HATCH" "DIMENSION"
       )
      )
    (progn
      (princ "\n选择目标对象:<特性匹配>")
      (setq ss (ssget (list (cons 0 ty))))
      (command "matchprop" mame ss "")
    )
  )
  (redraw mame 4)
  (setvar "nomutt" 0)
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

ziyouwzb

这个刷子不简单，太牛了！

730527

确实好用！感谢楼主

hpy

不错，挺实用的。

【KAIXIN】

个人建议：楼主可以另做程序（同样是一个命令）
1.刷图层   2.颜色  3.线型  4.样式  

自贡黄明儒

再用一下caoying在拜年贴中那把刷子，就更好。

革天明

太强大了，谢谢楼主分享

langjs

【KAIXIN】 发表于 2011-12-20 08:16
个人建议：楼主可以另做程序（同样是一个命令）
1.刷图层   2.颜色  3.线型  4.样式

难道是Cad 自带的“特性匹配”？

MJCADLWF

感谢楼主，太实用了！

669423907

楼主的程序非常好用啊！

cxs259

请问楼主，刷相同块时，为什么所有相同块会重贴在一起？

vlisp2012

程序很强大，。
而且程序的前面没带序号，很容易复制下来。
带序号的程序，真让人头疼。为啥非得带序号呢？