模拟院长的超级刷子功能，实用但界面不够美观。。。。
本帖最后由 77077 于 2015-6-5 12:42 编辑绝对原创，啥也不说了，直接上源码，求高手们拓展改进~~~
(defun MAKE-DCL-SSS (lst FILENAME / F1 I)
(if (setq F1 (open FILENAME "w"))
(progn
(write-line "MY_SSS: dialog{ label = \"我的小刷子 \";" F1)
(write-line ":boxed_column{ label=\"点选要刷相同的属性:\";" F1)
(setq I 0)
(foreach N lst
(progn
(write-line
(strcat ":toggle{ label=\""
(strcat (car N) " " (vl-princ-to-string (cdr N)))
"\"; key = \"KEY"
(itoa I)
"\"; width=35;action=\"(do-addlst "
(itoa I)
")\";value=\"0\";}"
)
F1
)
(setq I (1+ I))
)
);end foreach
(write-line "}" F1)
(write-line "ok_only;" F1)
(write-line "}" F1)
(close F1)
t
)
)
)
(defun do-addlst (INT)
(if (= $VALUE "1") ;_表示被选中
(setq LST1 (cons INT LST1))
(setq LST1 (vl-remove INT LST1))
)
)
;组码批量修改
(defun pgzm (ss lst / e el i)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq el (entget e))
(mapcar '(lambda (x / l)
(if (setq l (assoc (car x) el))
(setq el (subst x l el))
(setq el (append el (list x)))
)
)
lst
)
(entmod el)
)
)
;;;==============================
(defun c:matdxf(/ DXFLST1 EntType DXFLST DXFLST2 x y y2 dcl_name ID ID2 LST1 LST2 n lst3 SS I ENTI TMP)
(princ "\n 我的小刷子，同类刷")
(setq DXFLST1 (entget(car(entsel "\n点取源对象: ")))
EntType (cdr (assoc 0 DXFLST1))
)
(if (not (assoc 62 DXFLST1))
(setq DXFLST1 (append DXFLST1 (list '(62 . 256))))
)
(setq DXFLST
(cond
((= EntType "ARC") ;分支
'(
(10 . "圆心坐标")
(40 . "圆弧半径")
(50 . "起点角度")
(51 . "终点角度")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "ATTDEF") ;分支
'(
(1 . "默认值")
(2 . "标记字符串")
(3 . "提示字符串" )
(7 . "文字样式")
(10 . "文字基点")
(40 . "文字高度")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "CIRCLE") ;分支
'(
(10 . "圆心坐标")
(40 . "圆形半径")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "POINT") ;分支
'(
(10 . "点的位置")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "LINE") ;分支
'(
(10 . "起点坐标")
(11 . "终点坐标")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "TEXT") ;分支
'(
(1 . "文字内容")
(7 . "文字样式")
(10 . "插入位置")
(40 . "文字高度")
(41 . "宽度系数")
(50 . "旋转角度")
(51 . "倾斜角度")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "INSERT") ;分支
'(
(2 . "图块名称")
(10 . "图块位置")
(41 . "X 轴比例")
(42 . "Y 轴比例")
(43 . "Z 轴比例")
(50 . "旋转角度")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "LWPOLYLINE") ;分支
'(
(43 . "固定宽度")
(38 . "复线标高")
(39 . "复线厚度")
(70 . "是否闭合")
(8 . "所在图层")
(62 . "实体颜色")
))
((= EntType "MTEXT") ;分支
'(
(10 . "插入位置")
(1 . "文字内容")
(7 . "文字样式")
(40 . "文字高度")
(41 . "参照宽度")
(50 . "旋转角度")
(71 . "附着点")
(8 . "所在图层")
(62 . "实体颜色")
))
(t (alert "不支持的类型"));分支
);END cond
);setq
(if DXFLST
(progn
(foreach x DXFLST ;转化成人能轻易识别的DXF组码表
(if (setq y (assoc (car x) DXFLST1))
(setq y2 (LIST (cdr x) (cdr y))
DXFLST2 (cons y2 DXFLST2)
)
)
)
(setq DXFLST (mapcar '(lambda (X) (cons (cdr X) (car X))) DXFLST))
(setq dcl_name (strcat (getenv "temp") "\\AcadMat" ".dcl"));;创建临时对话框文件
(MAKE-DCL-SSS DXFLST2 dcl_name) ;;;开始写对话框
(>= (setq ID (load_dialog dcl_name)) 0) ;;;载入对话框文件
(new_dialog "MY_SSS" ID) ;;;初始化对话框，在屏幕上显示
(setq ID2 (start_dialog)) ;;;启动对话框
(if (and (= ID2 1) (> (length LST1) 0))
(progn
(foreach N LST1 (setq LST2 (cons (nth N DXFLST2) LST2))) ;取出要修改的组码代号
(setq LST2 (mapcar '(lambda(X) (cdr(assoc X DXFLST))) (mapcar 'car LST2)));从原图元中取出对应的值
(foreach x LST2 ;还原成电脑识别的DXF组码表
(setq lst3 (cons (assoc x DXFLST1) lst3))
)
(princ "\n选择要刷同的同类实体：")
(while (setq SS (ssget (list (cons 0 EntType)))) ;过滤选择要处理的对象
(pgzm ss lst3)
(princ "\n>>>>继续选择要刷同的同类实体<右键退出>：")
)
);progn
);if
(unload_dialog ID);;;卸载对话框文件
(vl-file-delete dcl_name)
);progn
);if
(princ)
) 给楼主参考下吧
;;Command / Functions --
;;c:AxProps -- prompts you to to select an entity.
;;c:NAxProps -- prompts you to to select a nested entity.
;;AxProps, syntax: (AxProps x), where x is any valid object, ename or handle.
(defun c:Propsx ( / mia getkey key lst )
(cond
( (and
(setq mia (null AxProps))
(null (findfile "axprops.fas"))
)
(princ "Cannot find axprops.fas, aborting.")
)
( (and
mia
(eq 'failed (load "axprops.fas"))
)
(princ "Cannot load axprops.fas, aborting.")
)
( (defun GetKey ( / result )
(while
(null
(eq 2
(car
(setq result (grread))
)
)
)
)
(cadr result)
)
(setq lst
(mapcar 'ascii
'("p" "P" "n" "N" "\r" " ")
)
)
(if mia (princ "\n\n"))
(princ
(strcat
"Press or to select a "
"primary entity, for a nested one: "
)
)
(while
(null
(member
(setq key (GetKey))
lst
)
)
)
(setq ename
(car
(if (member key (mapcar 'ascii '("n" "N")))
(nentsel)
(entsel)
)
)
)
(vl-load-com)
(AxProps ename)
)
)
(princ)
)
上一个对话框整合版的!
命令: MATDXF
我的小刷子，同类刷
点取源对象: 错误 : 参数太多 贴上院长的超级刷子
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=109750 感谢 77077 分享程序!!! 谢谢分享程序!!! 啥也不说了，谢谢楼主 怎么点了出了对话框后没反应？ 确实点击了没反应 多谢楼上提醒，已经更新了~
原因是论坛插件修改了代码
本来是(defun do-addlst (INT)
(if (= $VALUE "1") ;_表示被选中
(setq LST1 (cons INT LST1))
(setq LST1 (vl-remove INT LST1))
)
)贴出来后变成了(defun do-addlst (INT)
(if (= $$$$VALUE "1") ;_表示被选中
(setq LST1 (cons INT LST1))
(setq LST1 (vl-remove INT LST1))
)
) lucas_3333 发表于 2015-6-5 12:54 static/image/common/back.gif
给楼主参考下吧
让高手见笑了，我怎么不会用你这个程序呀？求演示~~~