- 积分
- 1575
- 明经币
- 个
- 注册时间
- 2020-6-5
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本帖最后由 dd131028 于 2023-10-4 14:01 编辑
之前在明经上下载的，一直用的好好的，上个月好好的就不能用了，出现错误，请问大家怎么回事？谢谢。。。
*******************************************************************************************************
;;; 《相同刷》v2.2 =========================================================
;;; 功能：
;;; <文字相同> 如源对象为文字， 则目标文字、天正文字内容相同(不支持天正多行， 点选程序刷属性和块内文字)
;;; <半径相同>如源对象为圆或弧，则目标圆或圆弧刷成半径相同
;;; <块相同> 如源对象为块， 则目标块刷成源块一样
;;; <线宽相同>如源对象为多段线，则目标线、圆、圆弧、多段线等刷成同线宽
;;; <线长相同>如源对象为直线， 则目标直线刷成长度相等
;;; <尺寸相同> 如源对象为尺寸， 则目标尺寸刷成数值相等
;;; <特性匹配> 如源对象为填充， 则目标特性匹配
;;; <椭圆相同 > 如源对象为椭圆， 则目标椭圆相同
;;; 使用：命令：mm，选择一个源对象，程序自动判断，再选择集
;;; ==================================================
(defun c:mm (/ #errxts $orr buk en1 ent i n name name1 obj p p1 p2 r snap ss tp ty uu)
(defun #errxts (s) ; 出错处理程序
(redraw name 4)
(setvar "nomutt" 0)
(setvar "PICKBOX" buk)
(setvar "osmode" snap)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
(defun emod (ent i n)
(subst (cons i n)(assoc i ent)ent)
)
(setq $orr *error*)
(setq *error* #errxts)
(vl-load-com) ; 主程序开始
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq snap (getvar "osmode"))
(setvar "osmode" 0)
(setq buk (getvar "PICKBOX"))
(setvar "PEDITACCEPT" 1) ; 下面程序选择合适的源对象，如没选到重新选
(while (not (and
(setq name1 (nentsel "\n选择源对象:"))
(setq name (car name1))
(setq ent (entget name))
(setq ty (cdr (assoc 0 ent)))
(member ty (list "TEXT" "MTEXT" "LWPOLYLINE" "CIRCLE" "INSERT" "LINE" "ARC" "HATCH" "DIMENSION" "ATTRIB" "TCH_ARROW" "TCH_TEXT" "TCH_DRAWINGNAME" "TCH_MULTILEADER" "TCH_ELEVATION" "ELLIPSE" ))
))
(if (= 52 (getvar "errno"))(vl-exit-with-error ""))
) ; 下面程序加了一个判断，如果源对象选择的是块，且不是属性或者块内文字，则认为选择的是块
(if (and (not (member ty (list "TEXT" "MTEXT" "ATTRIB")))
(= (type (car (last name1))) 'ename)
(member (cdr (assoc 0 (entget (car (last name1))))) '("INSERT" "DIMENSION")))
(setq name (car (last name1)) ent (entget name) ty (cdr (assoc 0 ent)))
)
(redraw name 3)
(setvar "nomutt" 1)
(setvar "PICKBOX" (fix (+ 1 (* 1.2 buk))))
(cond ; 1、 如果源对象是文字、天正文字或者块内文字或者属性，则执行。。。
((member ty (list "TEXT" "MTEXT" "ATTRIB" "TCH_TEXT" "TCH_ARROW" "TCH_DRAWINGNAME" "TCH_MULTILEADER" "TCH_ELEVATION"))
(setq uu (cdr (assoc 1 ent)))
(princ (strcat "\n <文字相同> T = " "\"" uu "\" (点选刷属性或块内文字)"))
(while t
(setq ss (ssget ":S" '((0 . "TEXT,MTEXT,INSERT,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION"))))
(repeat (setq i (sslength ss))
(setq ent (entget (setq en1 (ssname ss (setq i (1- i)))))tp (cdr (assoc 0 ent)))
(cond
((member tp (list "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))
)
(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))))
(if (member tp (list "TEXT" "MTEXT" "ATTRIB"))
(progn
(vla-put-textstring (vlax-ename->vla-object en1) uu)
(entupd en1) (entupd ent))
))
(if (member tp '("TEXT" "MTEXT")) ; 第一种,目标文字多选文字
(entmod (emod ent 1 uu))
))))
)
((member ty '("CIRCLE" "ARC")) ; 3、 如果源对象是圆，则循环更新目标圆的直径
(setq uu (cdr (assoc 40 ent)))
(princ (strcat "\n <半径相同> R = " (rtos uu 2 2)))
(while (setq ss (ssget ":S" '((0 . "CIRCLE,ARC"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (emod ent 40 uu))
))
)
((member ty '("INSERT" "ELLIPSE")) ; 4、 如果源对象是块，则拷贝源块到目标块的位置，删除目标块
(princ (strcat " \n <" (cadr (assoc ty '(("INSERT" "块") ("ELLIPSE" "椭圆")))) "相同>")); 5、 椭圆同上
(setq uu (cdr (assoc 10 ent)) name1 (cdr (car ent)))
(while (setq ss (ssget ":S" (list (cons 0 ty))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(command "COPY" name "" uu (cdr (assoc 10 ent)))
)
(if (ssmemb name1 ss) (ssdel name1 ss))
(command "ERASE" ss "")
)
)
((= ty "LWPOLYLINE") ; 6、 如果源对象是多义线，则转化目标对象的线宽
(if (not (setq uu (cdr (assoc 43 ent))))(setq uu (cdr (assoc 40 ent))))
(princ (strcat "\n <线宽相同> W = " (rtos uu 2 2)))
(while (setq ss (ssget ":S" '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))
(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)
))))
)
((= ty "LINE") ; 7、如果源对象是直线，则目标直线线长相同
(setq uu (* 0.5 (distance (cdr (assoc 10 ent)) (cdr (assoc 11 ent)))))
(princ (strcat "\n <线长相同> L = " (rtos uu 2 2)))
(while (setq ss (ssget ":S" '((0 . "LINE"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i))))p1 (cdr (assoc 10 ent))
p2 (cdr (assoc 11 ent)) r (angle p1 p2)
p (polar p1 r (* 0.5 (distance p1 p2))))
(entmod (emod (emod ent 10 (polar p r (* -1 uu))) 11 (polar p r uu)))
))
)
((= ty "DIMENSION") ; 8、如果源对象是尺寸，则尺寸数值相同
(setq obj (vlax-ename->vla-object name) uu (vla-get-textoverride obj))
(if (or(= uu "")(wcmatch uu "*<>*"))
(setq uu (rtos (vla-get-measurement obj) 2 (vla-get-toleranceprecision obj)))
)
(princ (strcat "\n <尺寸相同> T = " uu))
(while (setq ss (ssget ":S" '((0 . "DIMENSION"))))
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(entmod (emod ent 1 uu))
))
)
((member ty '("HATCH")) ; 9、如果源对象是填充，则调用特性匹配命令
(princ "\n <特性匹配>")
(while (setq ss (ssget ":S" '((0 . "HATCH"))))
(command "matchprop" name ss "")
(princ "\n <特性匹配>")
))
)
(redraw name 4)
(setvar "nomutt" 0)
(setvar "PICKBOX" buk)
(setvar "osmode" snap)
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看，没有账号？注册
x
|
发表于 2023-10-4 13:57:30
置顶卡
变色卡
显身卡
楼主
，好像不行，我用的是CAD2023，之前CAD2023用一直有用的，突然就没用。怪事！