求帮忙，编写一个，快速填充图案的 LISP程序

lizhaojun45

论坛里，我找了几个，都用不了。
请各位帮帮忙，需要发布源码。先谢谢了。
第一步：输入命令，HH
第二步：直接拾取内部点（可以拾取多个），或者输入 （字母 D )，
然后选择对象，也就是边界，我平时遇到的这种选边界的用途，是一个矩形里面
还有一个小一点的矩形，在两个矩形之间，不重叠的区域填充图案，这两个矩形
有可能是整体的多义线，也可能是相交的直线段。起来（可点选也可以框选），
正常情况下，用的都是拾取内部点。
第三步：设置填充原点（鼠标直接在屏幕上捕捉）
第四步：输入自定义的填充图案名称。（最好能加上提示功能，如，1代表什么图案，
2代表什么图案，3，代表什么图案），不输入名称，就默认使用最一个提示的图案。
注：生成的填充图案，程序会自动的放置到我指定的图层（瓷砖）
填充比例和角度都不用设置。都是一些自定好的填充图案。
这些填充图案，在有需要的时候，也能像系统自带的填充方式一样，可以随时分解/打散。

王鹏_pBZlo

(defun c:HH( / kw pt sset hatch_name op)
        (if (not (tblsearch "layer" "瓷砖")) (command "layer" "N" "瓷砖"""))
        (setq kw (getint "\n选择填充图案[801(1)/801-5(2)/802(3)/802-5(4)/清玻璃(5)/镜面(6)/磨砂玻璃(7)/艺术玻璃(8)/大理石(9)/复合木地板(10)/地毯(11)/地毯(12)/花岗岩(13)]<2>:"))
        (if (not kw) (setq kw 2))
        (cond         ((= kw 1) (setq hatch_name "801"))
                ((= kw 2) (setq hatch_name "801-5"))
                ((= kw 3) (setq hatch_name "802"))
                ((= kw 4) (setq hatch_name "802-5"))
                ((= kw 5) (setq hatch_name "AR-RROOF"))
                ((= kw 6) (setq hatch_name "AR-RROOF"))
                ((= kw 7) (setq hatch_name "AR-SAND"))
                ((= kw 8) (setq hatch_name "YS"))
                ((= kw 9) (setq hatch_name "大理石"))
                ((= kw 10) (setq hatch_name "DOLMIT"))
                ((= kw 11) (setq hatch_name "101"))
                ((= kw 12) (setq hatch_name "102"))
                ((= kw 13) (setq hatch_name "DOTS"))
                (t (setq hatch_name "801-5"))
        )
        (while (or (setq pt (getpoint "\n选择内部点:"))
                (if (not pt) (setq sset (ssget))))
                (setq op (getpoint "\n设置原点:"))
                (if pt (command "_.bhatch" "o" "s" op "N" "P" hatch_name (getvar "dimscale") "0" pt ""))
                (if sset (command "_.bhatch" "o" "s" op "N" "P" hatch_name (getvar "dimscale") "0" "s" sset "" ""))
                (command "change" (entlast) "" "p" "layer" "瓷砖" "")
        )
        (princ)
)

newer

非模式对话框"快速填充"工具

244 个回复 - 8968 次查看

本插件没用填充比例，而是用了平行线的间距控制，更准确的按照要求画图，不用担心比例不符合情形了。程序考虑了绘图比例，对话框输入的间距，就是实际出图打印图纸的间距. **** 本内容被作者隐藏 ****

2013-12-1 15:36 - newer - 每日插件

lizhaojun45

这个我查看过了。不符合要求.还看了，下面这个程序，有一部分功能可以用。但还是不太对。
http://bbs.xdcad.net/forum.php?m ... ht=%CC%EE%B3%E4LISP

newer

lizhaojun45 发表于 2019-4-14 21:41
这个我查看过了。不符合要求.还看了，下面这个程序，有一部分功能可以用。但还是不太对。
http://bbs.xdca ...

没一个程序能解决所有人的需要的，工具要善于组合和其他技巧综合运用，达到最快的画图目的。

lizhaojun45

这是我根据从网络上收集到的填充LISP插件，加以修改的的结果。虽然不完美，但还是能达到，60%的期望。发出来，大家帮忙修改一下。
;填充图案的 LISP插件
(defun c:HH(/ kw lay pt sc PTR1 PTR2 MAX-PT-X MIN-PT-X MAX-PT-Y MIN-PT-Y hatch_layer hatch_color)
;;;--------------------------------------
(setq lay (getvar "clayer"));;;图层相关设置，此行应该可以省略

(command "_layer" "s" "瓷砖" "");;;【把瓷砖图层置为当前工作层，根据需要来更改填充图案的放置层】
;;;如果没有这个瓷砖图层,使用这个HH命令前新建一个瓷砖图层，后面
;;;生成的填充图案，就自动的置入瓷砖图层了。
;;;----------------------------------------------------------------------------
(princ "\n /1 801/2 801-5/3 802/4 802-5/5 清玻璃/6 镜面/7 磨砂玻璃/8 艺术玻璃/9 大理石/0 复合木地板/11 地毯/12 地毯/13

花岗岩<2>");;;输入编号，确定选择用哪种图案来填充
;;;如果鼠标右击，就表示使用2#填充图案。★★★【这个功能还没有写出来】
;;;点选要填充的区域
;;;不使用上一步的，点选填充区域的方法，输入字母S，切换到，通过选择填充对象，来确定填充区域。
;;;;;鼠标右击，结束对象选择★★★【这个功能还没有写出来】
;;;;;设置新的填充原点★★★【这个功能还没有写出来】
(initget "1 2 3 4 5 6 7 8 9 0 11 12 13")
(setq kw (getkword))
(cond
        ((= kw "1")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "801" sc "0" pt );;;801代表自定义填充图案名称，“0”代表填充图案旋转角度，后面的参数类似。
        )
        ((= kw "2")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "801-5" sc "0" pt )
        )
        ((= kw "3")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "802" sc "0" pt )
        )
        ((= kw "4")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "802-5" sc "0" pt )
        )
        ((= kw "5")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "AR-RROOF" sc "0" pt )
        )
        ((= kw "6")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "AR-RROOF" sc "0" pt )
        )
        ((= kw "7")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "AR-SAND" sc "0" pt )
        )
        ((= kw "8")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "YS" sc "0" pt )
        )
        ((= kw "9")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "大理石" sc "0" pt )
        )            
        ((= kw "0")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "DOLMIT" sc "0" pt )      
        )
        ((= kw "11")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "101" sc "0" pt )
        )
        ((= kw "12")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        (command "_.bhatch" "p" "102" sc "0" pt )      
        )
        ((= kw "13")
        (setq pt (getpoint "\n 选择填充点"))
        (setq sc (* 1 (getvar "dimscale")))
        )
        (command "_.bhatch" "p" "DOTS" sc "0" pt )   
        ((= kw nil)
        )
)
(princ)
)

newer

lizhaojun45 发表于 2019-4-14 21:41
这个我查看过了。不符合要求.还看了，下面这个程序，有一部分功能可以用。但还是不太对。
http://bbs.xdca ...

你说说哪里不符合要求了？

王鹏_pBZlo

注意选5和6时你的程序里的图案都是AR-RROOF
(defun c:HH( / kw pt sset hatch_name)
        (if (not (tblsearch "layer" "瓷砖")) (command "layer" "N" "瓷砖"""))
        (setq kw (getint "\n选择填充图案[801(1)/801-5(2)/802(3)/802-5(4)/清玻璃(5)/镜面(6)/磨砂玻璃(7)/艺术玻璃(8)/大理石(9)/复合木地板(10)/地毯(11)/地毯(12)/花岗岩(13)]<2>:"))
        (if (not kw) (setq kw 2))
        (cond         ((= kw 1) (setq hatch_name "801"))
                ((= kw 2) (setq hatch_name "801-5"))
                ((= kw 3) (setq hatch_name "802"))
                ((= kw 4) (setq hatch_name "802-5"))
                ((= kw 5) (setq hatch_name "AR-RROOF"))
                ((= kw 6) (setq hatch_name "AR-RROOF"))
                ((= kw 7) (setq hatch_name "AR-SAND"))
                ((= kw 8) (setq hatch_name "YS"))
                ((= kw 9) (setq hatch_name "大理石"))
                ((= kw 10) (setq hatch_name "DOLMIT"))
                ((= kw 11) (setq hatch_name "101"))
                ((= kw 12) (setq hatch_name "102"))
                ((= kw 13) (setq hatch_name "DOTS"))
                (t (setq hatch_name "801-5"))
        )
        (while (or (setq pt (getpoint "\n选择内部点:"))
                (if (not pt) (setq sset (ssget))))
                (if pt (command "_.bhatch" "P" hatch_name (getvar "dimscale") "0" pt ""))
                (if sset (command "_.bhatch" "P" hatch_name (getvar "dimscale") "0" "s" sset "" ""))
                (command "change" (entlast) "" "p" "layer" "瓷砖" "")
        )
        (princ)
)

lizhaojun45

王鹏_pBZlo 发表于 2019-4-19 09:22
注意选5和6时你的程序里的图案都是AR-RROOF
(defun c:HH( / kw pt sset hatch_name)
        (if (not (t ...

王哥，指定/修改：图案填充的原点这个功能没有加进去。麻烦你有空的时候，改一下。我平时，每次填充都是这样填充的。每天的工作，就是画这些地砖铺贴图。精准度要求又高。

王鹏_pBZlo

lizhaojun45 发表于 2019-4-19 11:31
王哥，指定/修改：图案填充的原点这个功能没有加进去。麻烦你有空的时候，改一下。我平时，每次填充都是 ...

每一个填充都要设置原点吗?

lizhaojun45

王鹏_pBZlo 发表于 2019-4-19 12:46
每一个填充都要设置原点吗?

王哥，万分感谢， 最麻烦的问题，都解决好了。