帮忙更改一下lisp设置！

dd131028

请教各位论友，谁能帮更改一下狼大师的《相同刷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" '((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" '((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" '((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" '((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 '("OLYLINE" "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" '((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" '((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 "ICKBOX" 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 "ICKBOX"))
  (setvar "EDITACCEPT" 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 "ICKBOX" (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 '("OLYLINE" "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 "ICKBOX" buk)
  (setvar "osmode" snap)
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

ssyfeng

改了一下，你试试
v2.2版


v3.0版

ssyfeng

这个问题之前我记得你发过帖子吧，把command改成command-s不行？

dd131028

ssyfeng 发表于 2023-10-11 07:58
这个问题之前我记得你发过帖子吧，把command改成command-s不行？

试过了，没用，还是提示，我是直接将所有command替换成command-s的，不知对不对？

ssyfeng

试试我改的这个，我2022测试是没问题的

depgfdepgf

老大要右键两下才能退出，能改在右键一下就退出不？

dd131028

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就退出。

dd131028

ssyfeng 发表于 2023-10-12 08:33
改了一下，你试试
v2.2版

可能是我CAD版本的问题，2.2还是用不起来，算了，谢谢了。。。
3.0的还是要按2次ESC才能退出。

ssyfeng

后面改的这两个我在CAD2012和CAD2022测试都没问题的，不需要按2次才退出

depgfdepgf

老大很完美了，要是能刷尺寸就更完美了！！！