明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8099|回复: 34

[源码] 模拟院长的超级刷子功能,实用但界面不够美观。。。。

    [复制链接]
发表于 2015-6-4 21:08 | 显示全部楼层 |阅读模式
本帖最后由 77077 于 2015-6-5 12:42 编辑


绝对原创,啥也不说了,直接上源码,求高手们拓展改进~~~

  1. (defun MAKE-DCL-SSS        (lst FILENAME / F1 I)
  2. (if        (setq F1 (open FILENAME "w"))
  3.         (progn
  4.           (write-line "MY_SSS: dialog{ label = "我的小刷子 ";" F1)
  5.           (write-line ":boxed_column{   label="点选要刷相同的属性:";" F1)
  6.           (setq I 0)
  7.           (foreach N lst
  8.                   (progn
  9.                     (write-line
  10.                             (strcat        ":toggle{ label=""
  11.                                     (strcat (car N) "     " (vl-princ-to-string (cdr N)))
  12.                                     "";   key = "KEY"
  13.                                     (itoa I)
  14.                                     ""; width=35;  action="(do-addlst "
  15.                                     (itoa I)
  16.                                     ")";value="0";  }"
  17.                             )
  18.                            F1
  19.                     )
  20.                   (setq I (1+ I))
  21.                   )
  22.           );end foreach
  23.           (write-line "}" F1)
  24.           (write-line "ok_only;" F1)
  25.           (write-line "}" F1)
  26.           (close F1)
  27.           t
  28.         )
  29. )
  30. )
  31. (defun do-addlst (INT)
  32.     (if        (= $VALUE "1") ;_表示被选中
  33.         (setq LST1 (cons INT LST1))
  34.         (setq LST1 (vl-remove INT LST1))
  35.     )
  36. )
  37. ;组码批量修改
  38. (defun pgzm (ss lst / e el i)
  39.   (setq i -1)
  40.   (while (setq e (ssname ss (setq i (1+ i))))
  41.     (setq el (entget e))
  42.     (mapcar '(lambda (x / l)
  43.                (if (setq l (assoc (car x) el))
  44.                  (setq el (subst x l el))
  45.                  (setq el (append el (list x)))
  46.                )
  47.              )
  48.             lst
  49.     )
  50.     (entmod el)
  51.   )
  52. )
  53. ;;;==============================
  54. (defun c:matdxf(/ DXFLST1 EntType DXFLST DXFLST2 x y y2 dcl_name ID ID2 LST1 LST2 n lst3 SS I ENTI TMP)
  55.         (princ "\n 我的小刷子,同类刷")
  56.         (setq DXFLST1 (entget(car(entsel "\n点取源对象: ")))
  57.                     EntType (cdr (assoc 0 DXFLST1))
  58.              )
  59.         (if (not (assoc 62 DXFLST1))
  60.                 (setq DXFLST1 (append DXFLST1 (list '(62 . 256))))
  61.         )
  62.         (setq DXFLST
  63.         (cond
  64. ((= EntType "ARC")   ;分支
  65. '(
  66.                  (10 . "圆心坐标")
  67.                  (40 . "圆弧半径")
  68.                  (50 . "起点角度")
  69.                  (51 . "终点角度")
  70.                  (8 . "所在图层")
  71.                  (62 . "实体颜色")
  72.                  ))
  73. ((= EntType "ATTDEF")   ;分支
  74. '(
  75.      (1 . "默认值")
  76.                  (2 . "标记字符串")
  77.                  (3 . "提示字符串" )
  78.                  (7 . "文字样式")
  79.                  (10 . "文字基点")
  80.                  (40 . "文字高度")
  81.                  (8 . "所在图层")
  82.                  (62 . "实体颜色")
  83.                  ))
  84. ((= EntType "CIRCLE")   ;分支
  85. '(
  86.                  (10 . "圆心坐标")
  87.                  (40 . "圆形半径")
  88.                  (8 . "所在图层")
  89.                  (62 . "实体颜色")
  90.                  ))
  91. ((= EntType "POINT")   ;分支
  92. '(
  93.                  (10 . "点的位置")
  94.                  (8 . "所在图层")
  95.                  (62 . "实体颜色")
  96.                  ))
  97. ((= EntType "LINE")   ;分支
  98. '(
  99.                  (10 . "起点坐标")
  100.                  (11 . "终点坐标")
  101.                  (8 . "所在图层")
  102.                  (62 . "实体颜色")
  103.                  ))
  104. ((= EntType "TEXT")   ;分支
  105. '(
  106.                  (1 . "文字内容")
  107.                  (7 . "文字样式")
  108.                  (10 . "插入位置")
  109.                  (40 . "文字高度")
  110.                  (41 . "宽度系数")
  111.                  (50 . "旋转角度")
  112.                  (51 . "倾斜角度")
  113.                  (8 . "所在图层")
  114.                  (62 . "实体颜色")
  115.                  ))
  116. ((= EntType "INSERT")   ;分支
  117. '(
  118.      (2 . "图块名称")
  119.                  (10 . "图块位置")
  120.                  (41 . "X 轴比例")
  121.                  (42 . "Y 轴比例")
  122.                  (43 . "Z 轴比例")
  123.                  (50 . "旋转角度")
  124.                  (8 . "所在图层")
  125.                  (62 . "实体颜色")
  126.                  ))
  127. ((= EntType "LWPOLYLINE")   ;分支
  128. '(
  129.                  (43 . "固定宽度")
  130.                  (38 . "复线标高")
  131.                  (39 . "复线厚度")
  132.                  (70 . "是否闭合")
  133.                  (8 . "所在图层")
  134.                  (62 . "实体颜色")
  135.                  ))
  136. ((= EntType "MTEXT")   ;分支
  137. '(
  138.                  (10 . "插入位置")
  139.                  (1 . "文字内容")
  140.                  (7 . "文字样式")
  141.                  (40 . "文字高度")
  142.                  (41 . "参照宽度")
  143.                  (50 . "旋转角度")
  144.                  (71 . "附着点")
  145.                  (8 . "所在图层")
  146.                  (62 . "实体颜色")
  147.                  ))
  148.                  (t (alert "不支持的类型"));分支        
  149.          );END cond
  150. );setq
  151. (if DXFLST
  152. (progn
  153. (foreach x DXFLST   ;转化成人能轻易识别的DXF组码表
  154.         (if (setq y (assoc (car x) DXFLST1))
  155.           (setq y2 (LIST (cdr x) (cdr y))
  156.                 DXFLST2 (cons y2 DXFLST2)
  157.           )
  158.         )
  159. )
  160.   (setq DXFLST (mapcar '(lambda (X) (cons (cdr X) (car X))) DXFLST))
  161.   (setq dcl_name (strcat (getenv "temp") "\\AcadMat" ".dcl"));;创建临时对话框文件
  162.   (MAKE-DCL-SSS DXFLST2 dcl_name)              ;;;开始写对话框
  163.   (>= (setq ID (load_dialog dcl_name)) 0)      ;;;载入对话框文件
  164.   (new_dialog "MY_SSS" ID)                     ;;;初始化对话框,在屏幕上显示
  165.   (setq ID2 (start_dialog))                    ;;;启动对话框
  166. (if        (and (= ID2 1) (> (length LST1) 0))
  167.                 (progn                    
  168.                     (foreach N LST1 (setq LST2 (cons (nth N DXFLST2) LST2)))                  ;取出要修改的组码代号
  169.                     (setq LST2 (mapcar '(lambda(X) (cdr(assoc X DXFLST))) (mapcar 'car LST2)));从原图元中取出对应的值
  170.                     (foreach x LST2                                                           ;还原成电脑识别的DXF组码表
  171.                             (setq lst3 (cons (assoc x DXFLST1) lst3))
  172.                      )
  173.                      (princ "\n选择要刷同的同类实体:")
  174.                     (while (setq SS (ssget (list (cons 0 EntType))))                          ;过滤选择要处理的对象
  175.                             (pgzm ss lst3)
  176.                             (princ "\n  >>>>继续选择要刷同的同类实体<右键退出>:")        
  177.                     )
  178.                 );progn
  179. );if
  180. (unload_dialog ID);;;卸载对话框文件  
  181. (vl-file-delete dcl_name)
  182. );progn
  183. );if
  184. (princ)
  185. )

本帖子中包含更多资源

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

x

评分

参与人数 10明经币 +11 金钱 +10 收起 理由
永不言弃 + 1 + 10 赞一个!
tigcat + 1 很给力!
BaoWSE + 1 赞一个!
kwok + 1 赞一个!
xyp1964 + 2 山寨有理!
lidaxiu + 1 很给力!
emk + 1 神马都是浮云
ucuc2003 + 1 赞一个!定出更多源码!
lucas_3333 + 1 赞一个!
USER2128 + 1 赞一个!

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2015-6-5 12:54 | 显示全部楼层
给楼主参考下吧
  1. ;;Command / Functions --

  2. ;;c:AxProps -- prompts you to to select an entity.
  3. ;;c:NAxProps -- prompts you to to select a nested entity.
  4. ;;AxProps, syntax: (AxProps x), where x is any valid object, ename or handle.


  5. (defun c:Propsx ( / mia getkey key lst )

  6.     (cond
  7.    
  8.         (   (and
  9.                 (setq mia (null AxProps))
  10.                 (null (findfile "axprops.fas"))
  11.             )
  12.             (princ "Cannot find axprops.fas, aborting.")
  13.         )   
  14.         
  15.         (   (and
  16.                 mia
  17.                 (eq 'failed (load "axprops.fas"))
  18.             )
  19.             (princ "Cannot load axprops.fas, aborting.")
  20.         )
  21.         
  22.         (   (defun GetKey ( / result )
  23.                 (while
  24.                     (null
  25.                         (eq 2
  26.                             (car
  27.                                 (setq result (grread))
  28.                             )
  29.                         )
  30.                     )
  31.                 )
  32.                 (cadr result)
  33.             )

  34.             (setq lst
  35.                 (mapcar 'ascii
  36.                    '("p" "P" "n" "N" "\r" " ")
  37.                 )
  38.             )
  39.             
  40.             (if mia (princ "\n\n"))

  41.             (princ
  42.                 (strcat
  43.                     "Press [p] or [enter] to select a "
  44.                     "primary entity, [n] for a nested one: "
  45.                 )   
  46.             )

  47.             (while
  48.                 (null
  49.                     (member
  50.                         (setq key (GetKey))
  51.                         lst
  52.                     )
  53.                 )   
  54.             )

  55.             (setq ename
  56.                 (car
  57.                     (if (member key (mapcar 'ascii '("n" "N")))
  58.                         (nentsel)
  59.                         (entsel)
  60.                     )
  61.                 )
  62.             )
  63.             
  64.             (vl-load-com)

  65.             (AxProps ename)
  66.         )
  67.     )   

  68.     (princ)
  69.    
  70. )

本帖子中包含更多资源

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

x
回复 支持 0 反对 1

使用道具 举报

发表于 2015-6-6 08:39 | 显示全部楼层
上一个对话框整合版的!

本帖子中包含更多资源

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

x

点评

不要随便冠名, 这怎么是黄大的作品!  发表于 2015-6-9 08:35
回复 支持 1 反对 0

使用道具 举报

发表于 2024-2-4 00:13 | 显示全部楼层
命令: MATDXF
我的小刷子,同类刷
点取源对象: 错误 : 参数太多
 楼主| 发表于 2015-6-4 21:10 | 显示全部楼层
发表于 2015-6-4 21:33 | 显示全部楼层
感谢 77077 分享程序!!!
发表于 2015-6-5 07:15 | 显示全部楼层
谢谢分享程序!!!
发表于 2015-6-5 07:45 | 显示全部楼层
啥也不说了,谢谢楼主
发表于 2015-6-5 08:49 | 显示全部楼层
怎么点了出了对话框后没反应?
发表于 2015-6-5 10:34 | 显示全部楼层
确实点击了没反应
 楼主| 发表于 2015-6-5 12:46 | 显示全部楼层
多谢楼上提醒,已经更新了~
原因是论坛插件修改了代码
本来是
  1. (defun do-addlst (INT)
  2.     (if        (= $VALUE "1") ;_表示被选中
  3.         (setq LST1 (cons INT LST1))
  4.         (setq LST1 (vl-remove INT LST1))
  5.     )
  6. )
贴出来后变成了
  1. (defun do-addlst (INT)
  2.   (if (= $$$$VALUE "1") ;_表示被选中
  3.     (setq LST1 (cons INT LST1))
  4.     (setq LST1 (vl-remove INT LST1))
  5.   )
  6. )
 楼主| 发表于 2015-6-5 13:28 | 显示全部楼层
lucas_3333 发表于 2015-6-5 12:54
给楼主参考下吧

让高手见笑了,我怎么不会用你这个程序呀?求演示~~~
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 05:33 , Processed in 0.263633 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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