《相同刷》V2.5源码（增加一把小刷子）

langjs

---

在2.2基础上增加一把动态小刷子当刷线宽、线长、半径时，可键盘输入修改数值。
程序支持：单行文本，多行文本、尺寸标注、多重引线、属性块属性，块内文本、天正、
圆、圆弧、椭圆、图块、多段线、直线、填充等。


天正程序支持如下格式



其它功能



;;; 　　　         《相同刷》v2.5 (增加了一把小刷子)
;;; ======================================================================
;;; 功能：<文字相同>  源对象为文字，目标文字/尺寸/引线/天正文字内容刷成同内容
;;;                   (点选目标刷属性/块内文字)
;;;       <半径相同>  源对象为圆或弧，目标圆或圆弧刷成半径相同
;;;       <图块相同>  源对象为图块，目标块刷成源块一样
;;;       <线宽相同>  源对象为多段线，目标线/圆/圆弧/多段线等刷成同线宽
;;;       <线长相同>  源对象为直线，目标直线刷成长度相等
;;;       <尺寸相同>  源对象为尺寸，目标尺寸刷成数值相等
;;;       <特性匹配>  源对象为填充，目标特性匹配
;;;       <椭圆相同>，源对象为椭圆，目标椭圆刷成相同
;;; 使用：命令：xt，选择一个源对象，程序自动判断，再选择集
;;;       注意：当刷线宽、线长、半径时，可键盘输入修改数值。
;;; 作者：langjs           qq:59509100         日期:2020年4月
;;; ======================================================================
(defun c:xt (/ #errxts $orr cl code code1 d e en1 ent fun gr gr1 i loop loop1 lx n name name1 obj p p0 p1 p2 pd pr pt ptbak r s ss
               ss1 stl tp ty uu x y
            )
  (defun brushSS (fun / cl code code1 d e gr gr1 loop loop1 lx ptbak s ss stl x y) ; 模拟ssget功能显示小刷子
    (defun jpt (pt x y d)
      (list (list (+ (car pt) (* d x)) (+ (cadr pt) (* d y))))
    )
    (setq loop t)
    (while loop
      (setq gr (grread t 15 1)
            code (car gr)
            pt (cadr gr)
      )
      (cond
        ((= code 2)                       ; 键盘区域
          (if (and
                (member pt '(48 49 50 51 52 53 54 55 56 57))
                (member ty '("CIRCLE" "ARC"
                         "LWPOLYLINE" "LINE"
                        )
                )
              )
            (progn
              (setq s (chr pt)
                    loop1 t
              )
              (princ (strcat s))
              (while loop1
                (setq gr1 (grread  t 15 0 )
                      code1 (car gr1)
                      lx (cadr gr1)
                )
                  (redraw)
                (if (member lx '(46 48 49 50 51 52 53 54 55 56 57 8))
                  (progn
                  
                    (if (and
                          (> (setq stl (strlen s))
                             0
                          )
                          (= lx 8)
                        )               ; 当有键盘输入按了退格
                      (progn
                        (setq s (substr s 1 (1- stl))) ; 删除一个字
                        (princ (strcat "\n" pr s))
                      )                       ; 符并换行
                    )
                    (if (not (member lx '(8 13 32)))
                      (progn
                        (setq s (strcat s (chr lx)))
                        (princ (strcat (chr lx)))
                      )
                    )
                  )
                )
                (if (or
                      (member lx '(13 32))
                      (member code1 '(11 25))
                      (= (strlen s) 0)
                    )
                  (setq loop1 nil)
                )
              )
              (if (> (strlen s) 0)
                (progn
                  (setq uu (atof s))
                  (setq pr (strcat (substr pr 1 26) s ">"))
                )
              )
              (princ (strcat "\n" pr))
            )
          )
        )
        ((= code 3)                       ; 鼠标左键
          (redraw)
          (setq e (* 0.5 (getvar "pickbox"))
                e (append
                    (jpt pt e e d)
                    (jpt pt e (- e) d)
                    (jpt pt (- e) (- e) d)
                    (jpt pt (- e) 4 d)
                  )
          )
          (if (null ptbak)
            (if (setq ss (ssget "CP" e fun))
              (progn
                (setq loop nil
                      pd "Y"
                )
              )
              (setq ptbak pt)
            )
            (progn
              (if (= cl -1)
                (if (setq ss (ssget "_CP" (list pt (list (car pt) (cadr ptbak)) ptbak (list (car ptbak) (cadr pt)) pt) fun))
                  (setq loop nil)
                )
              )
              (if (= cl -3)
                (if (setq ss (ssget "W" ptbak pt fun))
                  (setq loop nil)
                )
              )
              (setq ptbak nil)
            )
          )
        )
        ((= code 5)                       ; 鼠标移动
          (redraw)
          (setq d (* 2 (/ (getvar "viewsize") (cadr (getvar "screensize")))))
          (grvecs (append
                    '(2)               ; 刷子颜色
                    (jpt pt 8.5 -3.2 d)
                    (jpt pt 8.5 -7 d)
                    (jpt pt 9.1 -3.2 d)
                    (jpt pt 9.1 -7 d)
                    (jpt pt 8 -7 d)
                    (jpt pt 8 -3.7 d)
                    (jpt pt 8 -3.7 d)
                    (jpt pt 8.5 -3.2 d)
                    (jpt pt 8.5 -3.2 d)
                    (jpt pt 9.1 -3.2 d)
                    (jpt pt 9.1 -3.2 d)
                    (jpt pt 9.6 -3.7 d)
                    (jpt pt 9.6 -3.7 d)
                    (jpt pt 9.6 -7 d)
                    (jpt pt 9.6 -7 d)
                    (jpt pt 6.2 -7 d)
                    (jpt pt 6.2 -7 d)
                    (jpt pt 5.7 -7.5 d)
                    (jpt pt 5.7 -7.5 d)
                    (jpt pt 5.7 -12 d)
                    (jpt pt 5.7 -12 d)
                    (jpt pt 12 -12 d)
                    (jpt pt 12 -12 d)
                    (jpt pt 12 -7.5 d)
                    (jpt pt 12 -7.5 d)
                    (jpt pt 11.5 -7 d)
                    (jpt pt 11.5 -7 d)
                    (jpt pt 9.6 -7 d)
                    (jpt pt 5.7 -12 d)
                    (jpt pt 3.7 -14.5 d)
                    (jpt pt 3.7 -14.5 d)
                    (jpt pt 10.0 -14.5 d)
                    (jpt pt 10.0 -14.5 d)
                    (jpt pt 12 -12 d)
                    (jpt pt 5.8 -14.5 d)
                    (jpt pt 7.8 -12 d)
                    (jpt pt 7.8 -14.5 d)
                    (jpt pt 9.9 -12 d)
                    (jpt pt 5.7 -8.8 d)
                    (jpt pt 12 -8.8 d)
                    (jpt pt 5.7 -10.2 d)
                    (jpt pt 12 -10.2 d)
                  )
          )
          (if ptbak
            (progn
              (if (< (car ptbak) (car pt))
                (setq cl -3)
                (setq cl -1)
              )
              (grvecs (list cl ptbak (list (car ptbak) (cadr pt)) (list (car ptbak) (cadr pt)) pt pt (list (car pt) (cadr ptbak))
                            (list (car pt) (cadr ptbak)) ptbak
                      )
              )
            )
            (grvecs (append
                      '(2)
                      (jpt pt -3 -3 d)
                      (jpt pt -3 3 d)
                      (jpt pt -3 3 d)
                      (jpt pt 3 3 d)
                      (jpt pt 3 3 d)
                      (jpt pt 3 -3 d)
                      (jpt pt 3 -3 d)
                      (jpt pt -3 -3 d)
                    )
            )
          )
        )
        ((member code '(11 25))               ; 鼠标右击
          (redraw)
          (setq loop nil)
        )
      )
    )
    SS
  )
  (defun #errxts (s)                       ; 出错处理程序
    (redraw name 4)
    (command ".UNDO" "E")
    (setq *error* $orr)
    (redraw)
    (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")               ;  (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" "MULTILEADER"
                           )
                )
              )
         )
    (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)
  (cond                                       ; 1、 如果源对象是文字、天正文字或者块内文字或者属性，则执行。。。
    ((member ty (list "TEXT" "MTEXT" "ATTRIB" "TCH_TEXT" "TCH_ARROW" "TCH_DRAWINGNAME" "TCH_MULTILEADER" "TCH_ELEVATION"
                      "MULTILEADER"
                )
     )
      (setq uu (cdr (assoc 1 ent)))
      (if (= ty "MULTILEADER")
        (setq uu (cdr (assoc 304 ent)))
      )
      (princ (setq pr (strcat "\n 文字相同,点选可刷块内文字及块属性：")))
      (while t
        (setq ss (brushSS '((0 . "TEXT,MTEXT,INSERT,TCH_ARROW,TCH_TEXT,TCH_DRAWINGNAME,TCH_MULTILEADER,TCH_ELEVATION,DIMENSION,MULTILEADER"))))
        (repeat (setq i (sslength ss))
          (setq ent (entget (setq en1 (ssname ss (setq i (1- i)))))
                tp (cdr (assoc 0 ent))
          )
          (cond
            ((member tp '("TEXT" "MTEXT"
                      "DIMENSION"
                     )
             )                               ; 如果目标文字多选文字
              (entmod (emod ent 1 uu))
            )
            ((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)
            )
            ((= tp "MULTILEADER")      ; 如果目标文字多选文字
              (entmod (emod ent 304 uu))
            )
          )
        )
        (if (= pd "Y")                       ; 如果是点选目标文字是块内文字或者属性
          (progn
            (setq ent (ssname ss 0))
            (if (not (setq en1 (car (nentselp pt))))
              (setq en1 ent)
            )
            (setq 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)
              )
            )
          )
          (setq pd "N")
        )
      )
    )
    ((member ty '("CIRCLE" "ARC"))     ; 3、 如果源对象是圆，则循环更新目标圆的直径
      (setq uu (cdr (assoc 40 ent)))
      (princ (setq pr (strcat "\n 半径相同,或输入新半径：<" (rtos uu 2 2) ">")))
      (while (setq ss (brushSS '((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 (setq pr (strcat " \n  " (cadr (assoc ty '(("INSERT" "块") ("ELLIPSE" "椭圆")))) "相同："))) ; 椭圆
      (setq uu (cdr (assoc 10 ent))
            name1 (cdr (car ent))
      )
      (while (setq ss (brushSS (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 (setq pr (strcat "\n 线宽相同,或输入新线宽：<" (rtos uu 2 2) ">")))
      (while (setq ss (brushSS '((0 . "LINE,ARC,POLYLINE,LWPOLYLINE,CIRCLE"))))
        (setq ss1 (ssadd))
        (repeat (setq i (sslength ss))
          (setq name1 (ssname ss (setq i (1- i)))
                tp (cdr (assoc 0 (setq ent (entget name1))))
          )
          (if (member tp (list "LINE" "ARC" "POLYLINE" "LWPOLYLINE"))
            (setq ss1 (ssadd name1 ss))
          )
          (if (= tp "CIRCLE")
            (progn
              (setq p0 (cdr (assoc 10 ent)))
              (setq r (cdr (assoc 40 ent)))
              (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") (assoc 8 ent) '(100 . "AcDbPolyline") '(90 . 2) '(70 . 1)
                             (cons 43 uu) (list 10 (- (car p0) r) (cadr p0)) '(42 . 1.0) (list 10 (+ (car p0) r) (cadr p0)) '
                             (42 . 1.0)
                       )
              )
              (entdel name1)
            )
          )
        )
        (if (> (sslength ss1) 0)
          (command "pedit" "M" ss1 "" "w" uu "x")
        )
      )
    )
    ((= ty "LINE")                       ; 7、如果源对象是直线，则目标直线线长相同
      (setq uu (* 0.5 (distance (cdr (assoc 10 ent)) (cdr (assoc 11 ent)))))
      (princ (setq pr (strcat "\n 线长相同,或输入新线长：<" (rtos uu 2 2) ">")))
      (while (setq ss (brushSS '((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 (setq pr (strcat "\n 尺寸相同：<" uu ">")))
      (while (setq ss (brushSS '((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 (setq pr "\n 特性匹配："))
      (while (setq ss (brushSS '((0 . "HATCH"))))
        (command "matchprop" name ss "")
        (princ "\n 特性匹配:")
      )
    )
  )
  (redraw name 4)
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

再见熊猫衣服

狼版主，你的那个相同刷，可以支持一下浩辰cad吗？或者说，支持一下天正T8版本。
我在使用的时候，发现不支持浩辰建筑CAD的图名标注的识别。
希望能更新兼容一下，谢谢了。
可以捐赠。

狼版主，你的那个相同刷，可以支持一下浩辰cad吗？或者说，支持一下天正T8版本。
我在使用的时候，发现不支持浩辰建筑CAD的图名标注的识别。
希望能更新兼容一下，谢谢了。
可以捐赠。

dd131028

命令: (LOAD "C:/Users/yc_xu/Downloads/《相同刷》v2.5.lsp")
选择源对象:
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。

出现这种情况请问怎么处理啊？

asd19400

还增加一个功能就完美了，把文本的内容刷成尺寸里面的内容，比如文本内容为(加腋段范围)，点选一个尺寸，尺寸标注的长度为（500），最后尺寸内容修改成（加腋段范围）

bai2000

看看老大的程序中天正字体怎么做的

kwok

想看看，支持一下。

yaokui25

占个位置 嘿嘿

wyl605

这个好用试试看看下了。。。。。。。

hhhlike

好程序，楼主太棒了

yansu

能刷天正引线文字吗

龙城飞将36

好程序，楼主太棒了

USER2128

回复，拜读楼主大作!

注册

及时雨啊，狼版