本帖最后由 tianyi1230 于 2013-12-13 22:57 编辑
本人请求郎大师把相同刷2.0升级为动态单选框选及时反映那种，今天langjs 刚发给我，本人立马共享给明经大伙，不多说了，上源码，另上一个也是langjs 大师的刷字高的源码，希望大家帮忙也修改为动态反应那种，同时支持天正文字等，谢谢了！（估计langjs 不会反对我上传明经的）
;;; 《相同刷》v3.0
;;; ====================================================================
;;; 功能：如源对象为文字或属性，则目标文字、属性、块内文字内容刷成同内容
;;; 如源对象为天正文字，则刷目标天正文字内容相同，(不支持天正多行文字)
;;; 如源对象为圆或圆弧，则刷目标圆和圆弧成源半径相同，
;;; 如源对象为块，则目标块刷成源块一样，
;;; 如源对象为多段线，则目标线、圆、圆弧、多段线等刷成同线宽
;;; 如源对象为直线线，则目标直线线长相同
;;; 如源对象为填充，则目标特性匹配
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集
;;; 作者：langjs qq:59509100 日期:2013年6月
;;; ====================================================================
(defun c:xt3 (/ #errxts $orr en1 ent i name name1 p p1 p2 r shortc ss tp ty uu)
(defun 52errno ()
(if (= 52 (getvar "errno"))
(progn
(vl-cmdf "")
(#errxts)
(vl-exit-with-error "")
)
)
)
(defun #errxts (s)
(setvar "nomutt" 0)
(setvar "SHORTCUTMENU" shortc)
(command ".UNDO" "E") ; 出错处理程序
(setq *error* $orr)
(princ)
)
(setq $orr *error*)
(setq *error* #errxts)
(vl-load-com) ; 主程序开始
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq shortc (getvar "SHORTCUTMENU"))
(setvar "SHORTCUTMENU" 0) ; 下面程序选择合适的源对象，如没选到重新选
(while (not (and
(setq name1 (nentsel "\n命令: _xt 选择源对象:"))
(setq name (car name1))
(setq ent (entget name))
(setq ty (cdr (assoc 0 ent)))
(member ty '("TEXT" "MTEXT"
"LWPOLYLINE" "CIRCLE"
"INSERT" "LINE"
"ARC" "HATCH"
"DIMENSION" "ATTRIB"
"TCH_ARROW" "TCH_TEXT"
"TCH_DRAWINGNAME" "TCH_MULTILEADER"
"TCH_ELEVATION"
)
)
)
)
(if (= 52 (getvar "errno"))
(vl-exit-with-error "")
)
) ; 下面程序加了一个判断，如果源对象选择的是块，且不是属性或者块内文字，则认为选择的是块
(if (and
(not (member ty '("TEXT" "MTEXT"
"ATTRIB"
)
)
)
(= (type (car (last name1))) 'ename)
(= (cdr (assoc 0 (entget (car (last name1))))) "INSERT")
)
(setq name (car (last name1))
ent (entget name)
ty (cdr (assoc 0 ent))
)
)
(if (and
(= (member ty '("TEXT" "MTEXT")))
(= (type (car (last name1))) 'ename)
(= (cdr (assoc 0 (entget (car (last name1))))) "INSERT")
)
(setq name (car (last name1)))
)
(setvar "nomutt" 1)
(command "MATCHPROP" name)
(cond ; 1、 如果源对象是文字、天正文字或者块内文字或者属性，则执行。。。
((member ty '("TEXT" "MTEXT"
"ATTRIB" "TCH_TEXT"
"TCH_ARROW" "TCH_DRAWINGNAME"
"TCH_MULTILEADER" "TCH_ELEVATION"
)
)
(setq uu (cdr (assoc 1 ent)))
(while t
(princ (strcat "\n选择目标对象:<文字相同> T = " "\"" uu "\""))
(if (setq ss (ssget ":S:L" '((0 . "TEXT,MTEXT,INSERT,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION"))))
(if (= (caar (setq name1 (ssnamex ss 0))) 1) ; 如果目标文字是单选块内文字或者属性或普通文字，则执行。。。
(progn
(setq ent (ssname ss 0)
en1 (car (nentselp (trans (cadr (last (car name1))) 0 1)))
tp (cdr (assoc 0 (entget en1)))
)
(cond
((member tp '("TEXT" "MTEXT"
"ATTRIB"
)
)
(vla-put-textstring (vlax-ename->vla-object en1) uu)
(entupd en1)
(entupd ent)
)
((member tp '("TCH_TEXT" "TCH_ELEVATION"
"TCH_ARROW"
)
)
(vlax-put-property (vlax-ename->vla-object en1) 'text uu)
)
((= tp "TCH_DRAWINGNAME")
(vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
)
((= tp "TCH_MULTILEADER")
(vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
)
)
)
(progn ; 如果目标文字多选的是普通文字，则循环更新文字内容
(repeat (setq i (sslength ss))
(setq ent (entget (setq en1 (ssname ss (setq i (1- i))))))
(setq tp (cdr (assoc 0 ent)))
(cond
((member tp '("TEXT" "MTEXT"))
(entmod (subst
(cons 1 uu)
(assoc 1 ent)
ent
)
)
)
((member tp '("TCH_TEXT" "TCH_ELEVATION"
"TCH_ARROW"
)
)
(vlax-put-property (vlax-ename->vla-object en1) 'text uu)
)
((= tp "TCH_DRAWINGNAME")
(vlax-put-property (vlax-ename->vla-object en1) 'nametext uu)
)
((= tp "TCH_MULTILEADER")
(vlax-put-property (vlax-ename->vla-object en1) 'uptext uu)
)
)
)
)
)
)
(52errno)
)
)
((member ty '("CIRCLE" "ARC")) ; 3、 如果源对象是圆，则循环更新目标圆的直径
(setq uu (cdr (assoc 40 ent)))
(while t
(princ (strcat "\n选择目标对象:<半径相同> R = " (rtos uu 2 2)))
(if (setq ss (ssget ":S:L" '((0 . "CIRCLE,ARC"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (subst
(cons 40 uu)
(assoc 40 ent)
ent
)
)
)
)
(52errno)
)
)
((= ty "INSERT") ; 4、 如果源对象是块，则拷贝源块到目标块的位置，删除目标块
(setq uu (cdr (assoc 10 ent)))
(while t
(princ " \n选择目标对象:<块相同>")
(if (setq ss (ssget ":S:L" '((0 . "INSERT"))))
(progn
(vl-cmdf "")
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(command "COPY" name "" uu (cdr (assoc 10 ent)))
)
(command "ERASE" ss "")
(command "MATCHPROP" name)
)
)
(52errno)
)
)
((= ty "LWPOLYLINE") ; 5、 如果源对象是多义线，则转化目标对象的线宽
(if (not (setq uu (cdr (assoc 43 ent))))
(setq uu (cdr (assoc 40 ent)))
)
(while t
(princ (strcat "\n选择目标对象:<线宽相同> W = " (rtos uu 2 2)))
(if (setq ss (ssget ":S:L" '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))
(progn
(vl-cmdf "")
(repeat (setq i (sslength ss))
(setq name1 (ssname ss (setq i (1- i)))
tp (cdr (assoc 0 (setq ent (entget name1))))
)
(cond
((member tp '("LINE" "ARC"))
(command "pedit" name1 "w" uu "x")
)
((member tp '("POLYLINE" "LWPOLYLINE"))
(command "pedit" name1 "w" uu "x")
)
((= tp "CIRCLE")
(command "donut" (- (* (cdr (assoc 40 ent)) 2) uu) (+ (* (cdr (assoc 40 ent)) 2) uu) (cdr (assoc 10 ent)) "")
(entdel name1)
)
)
)
(command "MATCHPROP" name)
)
)
(52errno)
)
)
((= ty "LINE") ; 6、如果源对象是直线，则目标直线线长相同
(setq uu (distance (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
(while t
(princ (strcat "\n选择目标对象:<线长相同> L = " (rtos uu 2 2)))
(if (setq ss (ssget ":S:L" '((0 . "LINE"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(setq r (angle (setq p1 (cdr (assoc 10 ent)))
(setq p2 (cdr (assoc 11 ent)))
)
)
(setq p (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2)))
(setq ent (subst
(cons 10 (polar p r (* -0.5 uu)))
(assoc 10 ent)
ent
)
)
(entmod (subst
(cons 11 (polar p r (* 0.5 uu)))
(assoc 11 ent)
ent
)
)
)
)
(52errno)
)
) ; 7、其他的一些情况，则调用特性匹配命令
((= ty "HATCH")
(princ "\n选择目标对象:<特性匹配>")
(while t
(princ (strcat "\n选择目标对象:<线长相同> L = " (rtos uu 2 2)))
(if (setq ss (ssget ":S:L" '((0 . "HATCH"))))
(command ss)
)
(52errno)
)
)
)
(setq *error* $orr)
(princ)
)
(defun c:zz ()
(setq ent (car (entsel "\n选择：")))
(setq ent (entget ent))
(princ "\nent====")
(princ ent)
(princ)
)
| 
[复制链接]
发表于 2013-12-13 22:52:26
置顶卡
变色卡
显身卡
楼主