明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 134002|回复: 1089

[源码] 《相同刷》V2.5源码(增加一把小刷子)

    [复制链接]
发表于 2013-6-11 23:04 | 显示全部楼层 |阅读模式
本帖最后由 langjs 于 2020-4-24 14:42 编辑


在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)
)


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

langjs大师,论坛不是已经有相同刷3.0了吗?  发表于 2014-8-6 16:24
楼主,天正2013的文字怎么只能作为原对象,而不能作为被刷的对象呢?  发表于 2013-9-11 20:11

评分

参与人数 11明经币 +12 金钱 +15 收起 理由
ywx2020 + 10 很给力!
yanchao316 + 1 大师,这个会清除并关闭捕捉设置,每次用完.
434939575 + 1 不加不行。过意不去!
liuhaixin88 + 1 神马都是浮云
xyp1964 + 3 很给力!山寨一个玩玩!
ucuc2003 + 1 经常用!!感谢!!
【KAIXIN】 + 1 + 5 赞一个!
tranney + 1 很给力!等于是满足我悬赏帖的要求了,哈哈,.
dongya1235 + 1 很给力!
669423907 + 1 嘻唰唰很给力!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2021-11-13 12:59 | 显示全部楼层
狼版主,你的那个相同刷,可以支持一下浩辰cad吗?或者说,支持一下天正T8版本。
我在使用的时候,发现不支持浩辰建筑CAD的图名标注的识别。
希望能更新兼容一下,谢谢了。
可以捐赠。

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2023-9-20 13:48 | 显示全部楼层
命令: (LOAD "C:/Users/yc_xu/Downloads/《相同刷》v2.5.lsp")
选择源对象:
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。

出现这种情况请问怎么处理啊?
发表于 2018-9-16 03:05 | 显示全部楼层
还增加一个功能就完美了,把文本的内容刷成尺寸里面的内容,比如文本内容为(加腋段范围),点选一个尺寸,尺寸标注的长度为(500),最后尺寸内容修改成(加腋段范围)
发表于 2013-6-11 23:09 | 显示全部楼层
本帖最后由 bai2000 于 2013-6-11 23:11 编辑

看看老大的程序中天正字体怎么做的
发表于 2013-6-11 23:19 来自手机 | 显示全部楼层
想看看,支持一下。
发表于 2013-6-11 23:30 | 显示全部楼层
占个位置 嘿嘿
发表于 2013-6-12 06:43 | 显示全部楼层
这个好用试试看看下了。。。。。。。
发表于 2013-6-12 07:13 | 显示全部楼层
好程序,楼主太棒了
发表于 2013-6-12 07:24 | 显示全部楼层
能刷天正引线文字吗
发表于 2013-6-12 07:32 | 显示全部楼层
好程序,楼主太棒了
发表于 2013-6-12 07:52 | 显示全部楼层
回复,拜读楼主大作!
发表于 2013-6-12 08:07 | 显示全部楼层
及时雨啊,狼版

点评

不是官,别瞎叫。。。  发表于 2013-6-12 11:17
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 22:25 , Processed in 0.271517 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表