预设常用填充V1.1——用LISP来快速完成常用填充
本帖最后由 raimo 于 2012-6-26 07:51 编辑发布个我改好的v1.1版本给大家用
已经在我力所能及的范围内
重新设计并优化了代码，删除了原有拼凑部分，增加了记忆功能，提高使用方便性
谢谢大家的回复及使用，希望能对你的工作有一点小帮助
同时附上扩展过的填充文件，这样就不用改代码直接使用我预设好的填充图案了，直接覆盖掉CAD原有默认填充文件即可
（注意：如果你没用我附件里的填充文件，“木地板，木夹板，钢砼，木纹”几个无法使用，但你还是可以参照我的方法，自行修改代码为你自己常用的其他填充图案）
===========================
更新版本v1.1 请下载最新附件
;;V1.1 明经raimo 2012.06.06
;;1.优化代码,去掉拼凑代码重新设计
;;2.增加记忆功能，提高填充的使用方便性
;;3.使用附件里我的填充文件，就可以直接使用预设好的填充（直接覆盖掉CAD原有默认填充文件）
;; 否则“木地板，木夹板，钢砼，木纹”几个无法使用，但可以自行修改为其他填充
;;4.预设常用填充--------------------命令:TC
===========================
经常在明经获得 各位的帮助，现在把我自己研究出来的一个小工具拿出来分享，算是完成一直想回馈论坛的心愿吧
这个工具主要方便快速使用一些常用的填充比如我们装饰行业制图常用的，玻璃，木地板，地砖，实心墙体。。。
这里的一些设置我说明一下
1. 使用命令是TC---填充的意思
2. 选择数字来选择7种常用填充图案，可以根据这个模式自行增减
3. 木地板，木夹板，钢砼..几种填充是我扩充的填充文件里自带的，CAD默认的没有，可以自己根据情况设置相应的填充名字
4. 这里有几种我自己摸索出来的填充方法。CAD里的三种填充模式都可以找到对应的，也就是可以自行设置出自己的常用填充来，比较实用，所以我才想拿出来与大家分享，希望能有点帮助。
CAD里的三种填充模式
原帖地址：
http://bbs.mjtd.com/thread-93819-1-1.html
同时感谢某位不知名的朋友
因为这里面 MycadGetkword 函数是借用网上搜资料时发现的某段选择用的子程序，我没动脑子就直接拿来用了。。
;;V1.0 明经raimo 2012.05.30
;;预设常用填充--------------------TC
(defun c:TC (/ opt pt la)
(setvar "measurement" 1) ; 设置公制单位
(setvar "cmdecho" 0) ; 关闭命令响应
(setq opt (mycadgetkword "\n①玻璃 ②地砖300 ③地砖800 ④木地板 ⑤实体 ⑥木夹板 ⑦钢砼：<1>"'("1" "2" "3" "4" "5" "6" "7") "1"))
(cond
((= opt "1")(tianchong1))
((= opt "2")(tianchong2))
((= opt "3")(tianchong3))
((= opt "4")(tianchong4))
((= opt "5")(tianchong5))
((= opt "6")(tianchong6))
((= opt "7")(tianchong7)))
(princ))
(defun tianchong1 ()
(prompt "\n玻璃比例400,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "8")
(command "bhatch" "p" "AR-RROOF" "400" "45" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong2 ()
(prompt "\n300x300地砖,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "8")
(command "bhatch" "p" "U" "0" "300" "Y" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong3 ()
(prompt "\n800x800地砖,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "8")
(command "bhatch" "p" "U" "0" "800" "Y" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong4 ()
(prompt "\n灰色木地板,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "8")
(command "bhatch" "p" "木地板" "80" "0" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong5()
(prompt "\n灰色实体填充,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "8")
(command "bhatch" "p" "solid" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong6 ()
(prompt "\n暗色木夹板,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "250")
(command "bhatch" "p" "木夹板" "1" "0" pt "")
(command "color" oldcolor)
(princ)
)
(defun tianchong7 ()
(prompt "\n暗色钢砼,指定内部点\n")
(setq pt (getpoint))
(setq oldcolor (getvar "cecolor"))
(command "color" "250")
(command "bhatch" "p" "钢筋混凝土" "20" "0" pt "")
(command "color" oldcolor)
(princ)
)
(defun MycadGetkword(pro lst def / kw val)
(setq lst (apply 'append (mapcar '(lambda(e) (list (ascii (strcase e)) (ascii (strcase e T)))) lst)) def (ascii def))
(prompt pro)
(while (not (and (setq kw (grread nil) val (car kw) kw (cadr kw)) (member val '(2 11 25))
(if (or (= val 25) (and (= val 11) (= kw 0)) (member kw '(13 32))) (setq kw def) (member kw lst)))))
(strcase (vl-list->string (list kw))))
装了一大圈, 还是你的最好用. 谢谢楼主，学习 一下 感谢大佬分享 谢谢楼主，学习 一下 如果选择对象的话，语句该怎么改写呢 (vl-load-com)
(if (not (tblsearch "layer" "hatch"))(command "-layer" "m" "hatch" "c" "254" "" "l" "continuous" "" ""));加载图层hatch
(if (not *dblclkreactor*)(setq *dblclkreactor* (vlr-mouse-reactor nil'((:vlr-begindoubleclick . dblclkedit)))));0=打开反应器
(defun dblclkedit (reactorobject point)(if dblclk-edit (dblclk-edit point)))
(deftun dblclk-edit (dblclk_point / owner dblclk_etype p)(setq owner (nentselp (setq p (trans (car dblclk_point) 0 1))));指定点来选择对象
(if (and (= owner nil) (= 0 (getvar 'cmdactive))) ;有活动命令时不起作用
(vla-sendcommand (vla-get-activedocument(vlax-get-acad-object)) (strcat (rtos (car p) 2 3) "," (rtos (cadr p) 2 3) "tianc"))))
(defun c:tianc (/ opt pt la)
(setvar "measurement" 1)
(setq opt (mycadgetkword "\n①实体/②钢筋硷/③素硷/④墙体⑤阳台/⑥卫生司/⑦厨房: <1>"'("1" "2" "3" "4" "5" "6" "7") "1")))
(cond
((= opt "1")(tianchongl))
((= opt "2")(tianchong2))
((= opt "3")(tianchong3))
((= opt "4")(tianchong4))
((= opt "5")(tianchong5))
((= opt "6")(tiancbong6))
((= opt "7")(tianchong7)))(princ))
(defun tianchongl ()(prompt "\n实体填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "solid" pt ""))(setvar "clayer" la)); solid连续填充，指定内部点
(defun tianchong2 ()(prompt "\n钢筋砼填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "ar-conc" "4" "0" pt "")(command "bhatch" "p" "ansi3l" "160" "0" "@" ""))(setvar "clayer" la));ar-conc&ansi3l连续填充，指定内部点
(defun tianchong3 ()(prompt "\n素砼填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "ar-conc" "4" "0" pt ""))(setvar "clayer" la));ar-conc连续填充，指定内部点
(defun tianchong4 ()(prompt "\n墙体填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "ansi3l" "60" "0" pt ""))(setvar "clayer" la));ar-conc连续填充，指定内部点
(defun tianchong5 ()(prompt "\n阳台填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoi nt))(command "bhatch" "p" "ansi37" "60" "0" pt ""))(setvar "clayer" la));ansi37连续填充，指定内部点
(defun tianchong6 ()(prompt"\n卫生间填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "cross" "30" "0" pt ""))(setvar "clayer" la));cross连续填充，指定内部点
(defun tianchong7 ()(prompt "\n厨房填充,指定内部点\n")(setq la (getvar "clayer"))(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))(command "bhatch" "p" "angle" "30" "0" pt ""))(setvar "clayer" la));angle连续填充，指定内部点
(princ)
(defun mycadGetkword(pro 1st def / kw val)
(setq 1st (apply 'append (mapcar '(lambda(e) (list (ascii (strcase e)) (ascii (strcase e T)))) 1st)) def (ascii def))
(prompt pro)
(while (not (and (setq kw (grread nil) val (car kw) kw (cadr kw)) (member val'(2 11 25))
(if (or (= val 25) (and (= val 11)(=kw 0)) (member kw '(13 32))) (setq kw def) (member kw 1st)))))
(strcase (vl-list->string (list kw))))
和我抄的这段很像啊 楼主，你定义的“地砖”“木地板”的文件呢？无法填充 本帖最后由 raimo 于 2012-5-30 14:43 编辑
革天明 发表于 2012-5-30 13:14 static/image/common/back.gif
楼主，你定义的“地砖”“木地板”的文件呢？无法填充
我在说明里已经有提到，我们使用的填充图案文件是修改过的，普通CAD里没有这个图案，所以无法填充
因为是自己用得，所以没去修改它。你可以把木地板这部分替换为
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(defun tianchong4 ()
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(prompt "\n灰色木地板,指定内部点\n")
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(setq pt (getpoint))
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(setq oldcolor (getvar "cecolor"))
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(command "color" "8")
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(command "bhatch" "p" "DOMLIY" "500" "0" pt "")
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(command "color" oldcolor)
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif(princ)
[*]http://bbs.mjtd.com/source/plugin/mc_colorcode/images/jssc_none.gif)
hao3ren 发表于 2012-5-30 09:35 static/image/common/back.gif
(vl-load-com)
(if (not (tblsearch "layer" "hatch"))(command "-layer" "m" "hatch" "c" "254" "" "l" " ...
对，我在说明里也有提到，引用了这段程序来实现数字选择功能。 Dear Sir,
Nice code
some suggestion
1) add layer
2) add dialog (dcl) better selection 有意思，地板贴出来的是我在百度文库发的，楼主稍加利用修改，其实关键函数MycadGetkword和左键双击反应器都是取之明经，大家多看看旧帖子还会发现很多有用的函数哦