langjs 发表于 2011-12-20 00:21:03

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

本帖最后由 langjs 于 2011-12-22 22:17 编辑



;;; 　　　      《相同刷》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 发表于 2023-10-24 20:23:12

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

730527 发表于 2018-3-21 14:52:25

确实好用！感谢楼主

hpy 发表于 2011-12-20 07:53:00

不错，挺实用的。

【KAIXIN】 发表于 2011-12-20 08:16:11

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

自贡黄明儒 发表于 2011-12-20 08:18:55

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

革天明 发表于 2011-12-20 10:07:08

太强大了，谢谢楼主分享

langjs 发表于 2011-12-20 10:18:52

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

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

MJCADLWF 发表于 2011-12-20 20:07:17

感谢楼主，太实用了！

669423907 发表于 2011-12-20 20:21:21

楼主的程序非常好用啊！

cxs259 发表于 2011-12-20 20:34:52

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

vlisp2012 发表于 2011-12-20 20:47:44

程序很强大，。
而且程序的前面没带序号，很容易复制下来。
带序号的程序，真让人头疼。为啥非得带序号呢？
页: [1] 2 3 4 5 6 7
查看完整版本: 一个用来刷相同的刷子源码