帮忙更改一下lisp设置！
本帖最后由 dd131028 于 2023-10-10 14:35 编辑请教各位论友，谁能帮更改一下狼大师的《相同刷3.0》程序，按Esc退出，要按两次才能退出，第一出现设置，能否直接改成一次ESC直接退出，设置换成别的快捷键！万分感谢。。。
像以前《相同刷2.2》那样，按一次ESC就能直接退出。由于《相同刷2.2》出现command出现更改为command-s高版本CAD用不起来了。
;;; 《相同刷》v3.0
;;; ====================================================================
;;; 功能：如源对象为文字或属性，则目标文字、属性、块内文字内容刷成同内容
;;; 如源对象为天正文字，则刷目标天正文字内容相同，(不支持天正多行文字)
;;; 如源对象为圆或圆弧，则刷目标圆和圆弧成源半径相同，
;;; 如源对象为块，则目标块刷成源块一样，
;;; 如源对象为多段线，则目标线、圆、圆弧、多段线等刷成同线宽
;;; 如源对象为直线线，则目标直线线长相同
;;; 如源对象为填充，则目标特性匹配
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集
;;; 作者：langjs qq:59509100 日期:2013年12月
;;; ====================================================================
(defun c:nb (/ #errxts $orr en1 ent i name name1 p p1 p2 r ss tp ty uu)
(defun 52errno ()
(if (= 52 (getvar "errno"))
(progn
(vl-cmdf "")
(#errxts)
(vl-exit-with-error "")
)
)
)
(defun #errxts (s)
(setvar "nomutt" 0)
(command ".UNDO" "E") ; 出错处理程序
(setq *error* $orr)
(princ)
)
(setq $orr *error*)
(setq *error* #errxts)
(vl-load-com) ; 主程序开始
(setvar "cmdecho" 0)
(command ".UNDO" "BE") ; 下面程序选择合适的源对象，如没选到重新选
(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")
(while t
(princ "\n选择目标对象:<特性匹配>")
(if (setq ss (ssget ":S:L" '((0 . "HATCH"))))
(command ss)
)
(52errno)
)
)
)
(setq *error* $orr)
(princ)
)
(defun c:lpoiui ()
(setq ent (car (entsel "\n选择：")))
(setq ent (entget ent))
(princ "\nent====")
(princ ent)
(princ)
)
;;; 《相同刷》v2.2 =========================================================
;;; 功能：
;;; <文字相同> 如源对象为文字， 则目标文字、天正文字内容相同(不支持天正多行， 点选程序刷属性和块内文字)
;;; <半径相同>如源对象为圆或弧，则目标圆或圆弧刷成半径相同
;;; <块相同> 如源对象为块， 则目标块刷成源块一样
;;; <线宽相同>如源对象为多段线，则目标线、圆、圆弧、多段线等刷成同线宽
;;; <线长相同>如源对象为直线， 则目标直线刷成长度相等
;;; <尺寸相同> 如源对象为尺寸，则目标尺寸刷成数值相等
;;; <特性匹配> 如源对象为填充，则目标特性匹配
;;; <椭圆相同 > 如源对象为椭圆， 则目标椭圆相同
;;; 使用：命令：xts，选择一个源对象，程序自动判断，再选择集
;;; ==================================================
(defun c:xts (/ #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)
)
本帖最后由 ssyfeng 于 2023-10-12 09:26 编辑
改了一下，你试试
v2.2版
v3.0版
这个问题之前我记得你发过帖子吧，把command改成command-s不行？ 本帖最后由 dd131028 于 2023-10-11 08:24 编辑
ssyfeng 发表于 2023-10-11 07:58
这个问题之前我记得你发过帖子吧，把command改成command-s不行？
试过了，没用，还是提示，我是直接将所有command替换成command-s的，不知对不对？ 试试我改的这个，我2022测试是没问题的
老大要右键两下才能退出，能改在右键一下就退出不？
本帖最后由 dd131028 于 2023-10-11 22:18 编辑
ssyfeng 发表于 2023-10-11 14:12
试试我改的这个，我2022测试是没问题的
3.0的高版本CAD的可以用呢，就是有个麻烦的地方，要按2次ESC才能退出。
2.2版本的高版本CAD用不起来，提示command改成command-s
能否帮我2.2版本的改成高版本CAD能用的那种啊，我用您说的方法替换所有command后还是用不起来，或者帮我把3.0的改成按1次ESC就退出。
ssyfeng 发表于 2023-10-12 08:33
改了一下，你试试
v2.2版
可能是我CAD版本的问题，2.2还是用不起来，算了，谢谢了。。。
3.0的还是要按2次ESC才能退出。
后面改的这两个我在CAD2012和CAD2022测试都没问题的，不需要按2次才退出 老大很完美了，要是能刷尺寸就更完美了！！！
页:
[1]