求一个快速填充的程序

fire9527

使用要求：
1.输入命令，框选区域（类似于画矩形，可以从右下角往上框选，也可以从左上角往下框选）
2.框选的区域生成一个矩形，矩形里自动填充上  earth  这个图案
3.生成的矩形和图案颜色自动变为蓝色，所在图层自动变为“自动填充”这个图层
4.填充比例在程序中预先设定好

论坛里找了好久，一直没找到，太需要了！现将几个类似的帖子链接附上，供各位老大参考：
作者：ucuc2003  链接：  http://bbs.mjtd.com/forum.php?mo ... 42&page=1#pid565623
作者：raimo   链接： http://bbs.mjtd.com/forum.php?mod=viewthread&tid=95805
作者：edata   链接： http://bbs.mjtd.com/thread-108925-1-1.html

edata

1. ;;快速填充command版本
   
2. ;;code by edata@mjtd
   
3. ;;2014-6-16
   
4. ;;变函数参数
   
5. ;;(sk_hatch_cmd sk_ha_name sk_ha_scale sk_ha_ang)
   
6. ;;sk_ha_name 填充名字符串
   
7. ;;sk_ha_scale 填充比例 数字或数字字符串
   
8. ;;sk_ha_ang 填充角度 0-360度数字或数字字符串
   
9. ;;例子(sk_hatch_cmd "earth" 100 0.0)
   
10. (defun sk_hatch_cmd( sk_ha_name sk_ha_scale sk_ha_ang / bak_clay bak_col bak_cmd en0 en1 en2 p1 p3)
    
11.   (or sk_ha_name (setq sk_ha_name "earth"))
    
12.   (or sk_ha_scale (setq sk_ha_scale 100))
    
13.   (or sk_ha_ang (setq sk_ha_ang 0.0))
    
14.   (setq bak_clay(getvar 'clayer)
    
15.         bak_col(getvar 'cecolor)
    
16.         bak_cmd(getvar 'cmdecho)
    
17.         )  
    
18.   (if(not(tblobjname "layer" "自动填充"))
    
19.     (entmake (list '(0 . "LAYER")
    
20.                    '(100 . "AcDbSymbolTableRecord")
    
21.                    '(100 . "AcDbLayerTableRecord")
    
22.                    '(70 . 0)
    
23.                    '(6 . "Continuous")
    
24.                    (cons 2 "自动填充")
    
25.                    (cons 62 5)
    
26.              )
    
27.     )
    
28.     )
    
29.   (setvar 'clayer "自动填充")
    
30.   (setvar 'cecolor "5")
    
31.   (setvar 'cmdecho 0)
    
32.   (while (and(setq p1(getpoint "\n指定第一点:"))
    
33.                  (setq p3(getcorner p1 "\n指定对角点:"))
    
34.                  )
    
35.     (progn
    
36.       (if(> (getvar 'cmdactive) 0)(command))
    
37.       (setq en0(entlast))
    
38.       (command "_.RECTANG" "_non" p1 "_non" p3)
    
39.       (setq en1(entlast))
    
40.       (command "-bhatch" "p" sk_ha_name sk_ha_scale sk_ha_ang "s" en1 "" "")
    
41.       (if(> (getvar 'cmdactive) 0)(command))
    
42.       (setq en2(entlast))
    
43.       (if(sk_h5_eq en1 en2)
    
44.         (progn
    
45.         (alert "创建填充失败.")
    
46.         (if (not(sk_h5_eq en1 en0)) (entdel en1))
    
47.         )
    
48.         )
    
49.       )
    
50.     )  
    
51.   (and bak_clay(setvar 'clayer bak_clay))
    
52.   (and bak_col(setvar 'cecolor bak_col))
    
53.   (and bak_cmd(setvar 'cmdecho bak_cmd))  
    
54.   (princ)
    
55.   )
    
56. (defun sk_dxf(ent code)(cdr(assoc code (entget ent))))
    
57. (defun sk_h5_eq(ent1 ent2)
    
58.   (= (sk_dxf ent1 5)(sk_dxf ent2 5))
    
59.   )
    
60. (defun c:tt()
    
61.   (sk_hatch_cmd "earth" 100 0.0)
    
62.   (princ)
    
63.   )
    
64. (defun c:tt2()
    
65.   (sk_hatch_cmd "angle" 100 0.0)
    
66.   (princ)
    
67.   )

;;快速填充command版本<br /> ;;code by edata@mjtd<br /> ;;2014-6-16<br /> ;;变函数参数<br /> ;;(sk_hatch_cmd sk_ha_name sk_ha_scale sk_ha_ang)<br /> ;;sk_ha_name 填充名字符串<br /> ;;sk_ha_scale 填充比例 数字或数字字符串<br /> ;;sk_ha_ang 填充角度 0-360度数字或数字字符串<br /> ;;例子(sk_hatch_cmd "earth" 100 0.0)<br /> (defun sk_hatch_cmd( sk_ha_name sk_ha_scale sk_ha_ang / bak_clay bak_col bak_cmd en0 en1 en2 p1 p3)<br />   (or sk_ha_name (setq sk_ha_name "earth"))<br />   (or sk_ha_scale (setq sk_ha_scale 100))<br />   (or sk_ha_ang (setq sk_ha_ang 0.0))<br />   (setq bak_clay(getvar 'clayer)<br />         bak_col(getvar 'cecolor)<br />         bak_cmd(getvar 'cmdecho)<br />         )  <br />   (if(not(tblobjname "layer" "自动填充"))<br />     (entmake (list '(0 . "LAYER")<br />                    '(100 . "AcDbSymbolTableRecord")<br />                    '(100 . "AcDbLayerTableRecord")<br />                    '(70 . 0)<br />                    '(6 . "Continuous")<br />                    (cons 2 "自动填充")<br />                    (cons 62 5)<br />              )<br />     )<br />     )<br />   (setvar 'clayer "自动填充")<br />   (setvar 'cecolor "5")<br />   (setvar 'cmdecho 0)<br />   (while (and(setq p1(getpoint "\n指定第一点:"))<br />                  (setq p3(getcorner p1 "\n指定对角点:"))<br />                  )<br />     (progn<br />       (if(> (getvar 'cmdactive) 0)(command))<br />       (setq en0(entlast))<br />       (command "_.RECTANG" "_non" p1 "_non" p3)<br />       (setq en1(entlast))<br />       (command "-bhatch" "p" sk_ha_name sk_ha_scale sk_ha_ang "s" en1 "" "")<br />       (if(> (getvar 'cmdactive) 0)(command))<br />       (setq en2(entlast))<br />       (if(sk_h5_eq en1 en2)<br />         (progn<br />         (alert "创建填充失败.")<br />         (if (not(sk_h5_eq en1 en0)) (entdel en1))<br />         )<br />         )<br />       )<br />     )  <br />   (and bak_clay(setvar 'clayer bak_clay))<br />   (and bak_col(setvar 'cecolor bak_col))<br />   (and bak_cmd(setvar 'cmdecho bak_cmd))  <br />   (princ)<br />   )<br /> (defun sk_dxf(ent code)(cdr(assoc code (entget ent))))<br /> (defun sk_h5_eq(ent1 ent2)<br />   (= (sk_dxf ent1 5)(sk_dxf ent2 5))<br />   )<br /> (defun c:tt()<br />   (sk_hatch_cmd "earth" 100 0.0)<br />   (princ)<br />   )<br /> (defun c:tt2()<br />   (sk_hatch_cmd "angle" 100 0.0)<br />   (princ)<br />   )

Gu_xl

这个很容易啊！将命令行转成代码即可！

1. (defun c:tt ()
   
2.   (command "layer" "m" "自动填充" "")
   
3.   (setvar "cecolor" "5")
   
4.   (command "rectang" pause pause)
   
5.   (setq e (entlast))
   
6.   (command "hatch" "p" "earth" 1 0 e "")
   
7. )

(defun c:tt ()<br />   (command "layer" "m" "自动填充" "")<br />   (setvar "cecolor" "5")<br />   (command "rectang" pause pause)<br />   (setq e (entlast))<br />   (command "hatch" "p" "earth" 1 0 e "")<br /> )

theisland

G版，第一次运行时怎么有这个提示呢？
未知的图案名。填充图案太密
图案填充间距太密，或短划尺寸太小。 nil


多试几次就可以了，第一次总是有这个提示

fire9527

edata 发表于 2014-6-16 12:35

非常感谢，太好用了，还有其他图案可选

edata

同样的矩形和填充比例不匹配的时候，填充会失败哦。。。
这个是填充保护机制。

fire9527

edata 发表于 2014-6-16 13:02
同样的矩形和填充比例不匹配的时候，填充会失败哦。。。
这个是填充保护机制。

已经很好了，目前只发现如果框选范围太大会失败，不过一般不会框选太多的东西，问个很弱智的问题：怎么让新建的那个“自动填充”图层是不打印层？ 还有，如果扩展的几个命令能让新建图层指定到其他颜色应该更好看，比如  tt1：生成的图案为蓝色，图案1；tt2生成的图案为绿色，图案2；……但都是在同一个不打印图层上。这个功能有更好，没有也无所谓，已经能满足当时只需了，只是想到如果以后有扩展用途

edata

1. ;;快速填充command版本2
   
2. ;;code by edata@mjtd
   
3. ;;2014-6-16
   
4. ;;变函数参数
   
5. ;;(sk_hatch_cmd sk_ha_name sk_ha_scale sk_ha_ang sk_lay sk_col sk_isprint)
   
6. ;;sk_ha_name 填充名字符串
   
7. ;;sk_ha_scale 填充比例 数字或数字字符串
   
8. ;;sk_ha_ang 填充角度 0-360度数字或数字字符串
   
9. ;;sk_lay 图层名字符串 图层默认新建设置颜色和打印状态
   
10. ;;sk_col 颜色数值 0-256 0=byblock 256=bylayer
    
11. ;;sk_isprint t或 nil 图层是否打印 T=可以打印 nil不打印
    
12. ;;例子(sk_hatch_cmd "earth" 100 0.0 "自动填充" 1 nil)
    
13. (defun sk_hatch_cmd( sk_ha_name sk_ha_scale sk_ha_ang sk_lay sk_col sk_isprint / bak_clay bak_col bak_cmd en0 en1 en2 p1 p3 la_en la_elist)
    
14.   (or sk_ha_name (setq sk_ha_name "earth"))
    
15.   (or sk_ha_scale (setq sk_ha_scale 100))
    
16.   (or sk_ha_ang (setq sk_ha_ang 0.0))
    
17.   (or sk_lay (setq sk_lay "自动填充"))
    
18.   (or sk_col (setq sk_col 5))
    
19.   (setq bak_clay(getvar 'clayer)
    
20.         bak_col(getvar 'cecolor)
    
21.         bak_cmd(getvar 'cmdecho)
    
22.         )  
    
23.   (if(setq la_en (tblobjname "layer" sk_lay))
    
24.     (progn
    
25.       ;;强制更新图层状态
    
26.       ;(setq la_elist(entget la_en)
    
27.             ;la_elist(subst(cons 62 sk_col)(assoc 62 la_elist)la_elist) ;设置更新图层为设置新的颜色
    
28.             ;la_elist(subst(cons 290 (if sk_isprint 1 0))(assoc 290 la_elist)la_elist);设置更新图层的打印状态
    
29.             ;)
    
30.       ;(entmod la_elist)
    
31.       
    
32.       )
    
33.     (entmake (list '(0 . "LAYER")
    
34.                    '(100 . "AcDbSymbolTableRecord")
    
35.                    '(100 . "AcDbLayerTableRecord")
    
36.                    '(70 . 0)
    
37.                    '(6 . "Continuous")
    
38.                    (cons 2 sk_lay)
    
39.                    (cons 62 (if sk_col sk_col 5))
    
40.                    (cons 290 (if sk_isprint 1 0))
    
41.              )
    
42.     )
    
43.     )
    
44.   (setvar 'clayer sk_lay)
    
45.   (setvar 'cecolor (itoa sk_col) )
    
46.   (setvar 'cmdecho 0)
    
47.   (while (and(setq p1(getpoint "\n指定第一点:"))
    
48.                  (setq p3(getcorner p1 "\n指定对角点:"))
    
49.                  )
    
50.     (progn
    
51.       (if(> (getvar 'cmdactive) 0)(command))
    
52.       (setq en0(entlast))
    
53.       (command "_.RECTANG" "_non" p1 "_non" p3)
    
54.       (setq en1(entlast))
    
55.       (command "-bhatch" "p" sk_ha_name sk_ha_scale sk_ha_ang "s" en1 "" "")
    
56.       (if(> (getvar 'cmdactive) 0)(command))
    
57.       (setq en2(entlast))
    
58.       (if(sk_h5_eq en1 en2)
    
59.         (progn
    
60.         (alert "创建填充失败.")
    
61.         (if (not(sk_h5_eq en1 en0)) (entdel en1))
    
62.         )
    
63.         )
    
64.       )
    
65.     )  
    
66.   (and bak_clay(setvar 'clayer bak_clay))
    
67.   (and bak_col(setvar 'cecolor bak_col))
    
68.   (and bak_cmd(setvar 'cmdecho bak_cmd))  
    
69.   (princ)
    
70.   )
    
71. (defun sk_dxf(ent code)(cdr(assoc code (entget ent))))
    
72. (defun sk_h5_eq(ent1 ent2)
    
73.   (= (sk_dxf ent1 5)(sk_dxf ent2 5))
    
74.   )
    
75. (defun c:tt()
    
76.   (sk_hatch_cmd "earth" 100 0.0 "自动填充" 1 nil)
    
77.   (princ)
    
78.   )
    
79. (defun c:tt2()
    
80.   (sk_hatch_cmd "angle" 100 0.0 "自动填充2" 5 nil)
    
81.   (princ)
    
82.   )

;;快速填充command版本2<br /> ;;code by edata@mjtd<br /> ;;2014-6-16<br /> ;;变函数参数<br /> ;;(sk_hatch_cmd sk_ha_name sk_ha_scale sk_ha_ang sk_lay sk_col sk_isprint)<br /> ;;sk_ha_name 填充名字符串<br /> ;;sk_ha_scale 填充比例 数字或数字字符串<br /> ;;sk_ha_ang 填充角度 0-360度数字或数字字符串<br /> ;;sk_lay 图层名字符串 图层默认新建设置颜色和打印状态<br /> ;;sk_col 颜色数值 0-256 0=byblock 256=bylayer<br /> ;;sk_isprint t或 nil 图层是否打印 T=可以打印 nil不打印<br /> ;;例子(sk_hatch_cmd "earth" 100 0.0 "自动填充" 1 nil)<br /> (defun sk_hatch_cmd( sk_ha_name sk_ha_scale sk_ha_ang sk_lay sk_col sk_isprint / bak_clay bak_col bak_cmd en0 en1 en2 p1 p3 la_en la_elist)<br />   (or sk_ha_name (setq sk_ha_name "earth"))<br />   (or sk_ha_scale (setq sk_ha_scale 100))<br />   (or sk_ha_ang (setq sk_ha_ang 0.0))<br />   (or sk_lay (setq sk_lay "自动填充"))<br />   (or sk_col (setq sk_col 5))<br />   (setq bak_clay(getvar 'clayer)<br />         bak_col(getvar 'cecolor)<br />         bak_cmd(getvar 'cmdecho)<br />         )  <br />   (if(setq la_en (tblobjname "layer" sk_lay))<br />     (progn<br />       ;;强制更新图层状态<br />       ;(setq la_elist(entget la_en)<br />             ;la_elist(subst(cons 62 sk_col)(assoc 62 la_elist)la_elist) ;设置更新图层为设置新的颜色<br />             ;la_elist(subst(cons 290 (if sk_isprint 1 0))(assoc 290 la_elist)la_elist);设置更新图层的打印状态<br />             ;)<br />       ;(entmod la_elist)<br />       <br />       )<br />     (entmake (list '(0 . "LAYER")<br />                    '(100 . "AcDbSymbolTableRecord")<br />                    '(100 . "AcDbLayerTableRecord")<br />                    '(70 . 0)<br />                    '(6 . "Continuous")<br />                    (cons 2 sk_lay)<br />                    (cons 62 (if sk_col sk_col 5))<br />                    (cons 290 (if sk_isprint 1 0))<br />              )<br />     )<br />     )<br />   (setvar 'clayer sk_lay)<br />   (setvar 'cecolor (itoa sk_col) )<br />   (setvar 'cmdecho 0)<br />   (while (and(setq p1(getpoint "\n指定第一点:"))<br />                  (setq p3(getcorner p1 "\n指定对角点:"))<br />                  )<br />     (progn<br />       (if(> (getvar 'cmdactive) 0)(command))<br />       (setq en0(entlast))<br />       (command "_.RECTANG" "_non" p1 "_non" p3)<br />       (setq en1(entlast))<br />       (command "-bhatch" "p" sk_ha_name sk_ha_scale sk_ha_ang "s" en1 "" "")<br />       (if(> (getvar 'cmdactive) 0)(command))<br />       (setq en2(entlast))<br />       (if(sk_h5_eq en1 en2)<br />         (progn<br />         (alert "创建填充失败.")<br />         (if (not(sk_h5_eq en1 en0)) (entdel en1))<br />         )<br />         )<br />       )<br />     )  <br />   (and bak_clay(setvar 'clayer bak_clay))<br />   (and bak_col(setvar 'cecolor bak_col))<br />   (and bak_cmd(setvar 'cmdecho bak_cmd))  <br />   (princ)<br />   )<br /> (defun sk_dxf(ent code)(cdr(assoc code (entget ent))))<br /> (defun sk_h5_eq(ent1 ent2)<br />   (= (sk_dxf ent1 5)(sk_dxf ent2 5))<br />   )<br /> (defun c:tt()<br />   (sk_hatch_cmd "earth" 100 0.0 "自动填充" 1 nil)<br />   (princ)<br />   )<br /> (defun c:tt2()<br />   (sk_hatch_cmd "angle" 100 0.0 "自动填充2" 5 nil)<br />   (princ)<br />   )

fire9527

edata 发表于 2014-6-16 17:57

错误: 参数太多

特别申明：您的第一个程序已经足够用了，现在您写的并非急用，但以后有可能会用到，或者暂时还没想到应用的地方，我不想给老大们添麻烦，如果愿意，可以继续帮小弟调试，不理会这个后续要求也已经很满足了，非常感谢“edata”老大！

ucuc2003

2. ;;;;;;自动填充：ff；hhh
   
3. (defun c:ff ( / *Error* blipm eedel i plw pp1 pp2 ppa ppb ptlist rden redent usercmd userosm)
   
4.    (princ "快捷填充")
   
5.    (defun *Error* (msg)
   
6.      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
   
7.      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm))
   
8.      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   
9.    )
   
10.    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
    
11.    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE"))
    
12.   (while
    
13.    (progn
    
14.      (setvar "CMDECHO" 0)
    
15.      (setvar "OSMODE" 6839)
    
16.      (setq blipm(getvar "blipmode"))
    
17.      (setvar "blipmode" 0)
    
18.      (setq pp1(getpoint "\n指定第一点:"))
    
19.      (setq pp2(getcorner pp1  "\r指定对角点:"))
    
20.      (if (or (= pp1 nil) (= pp2 nil)) ""
    
21.          (progn
    
22.      (setq ppa (list (car pp2)(cadr pp1)))
    
23.      (setq ppb(list (car pp1) (cadr pp2)))
    
24.      (setq ptlist ( list pp1 ppa pp2 ppb))
    
25.      (setq plw(getvar "plinewid"))
    
26.      (setvar "plinewid" 0)
    
27.      (command "pline" pp1 ppa   pp2  ppb "c")
    
28.      (setvar "plinewid" plw)
    
29.      (setq eedel(entlast))
    
30.      (if (tblsearch "layer" "FILL") ""
    
31.        (command "layer" "New" "FILL" "c" "191" "FILL" "")
    
32.      )
    
33.      (command "hatch"  "" "" "" "l" "")
    
34.      (command "change" (entlast) "" "P" "la" "FILL" "")
    
35.      (entdel eedel)
    
36.      (setvar "blipmode" blipm)
    
37.      (setq redent(ssget "f" ptlist))
    
38.        (if (= redent nil)  ""
    
39.         (progn
    
40.           (setq i 1)
    
41.          (setq rden (ssname redent 0))
    
42.           (while rden
    
43.           (redraw rden)
    
44.           (setq rden (ssname redent i))
    
45.           (setq i (+ i 1))
    
46.           )
    
47.         )
    
48.       )  
    
49.     ))
    
50.    )
    
51. (princ "\n*继续*")
    
52. )
    
53.   (*Error* "")
    
54. (princ)
    
55. )
    
56. 
    
57. ;;;;;;自动画边界填充
    
58. (defun c:HHH ( / *Error* blipm i obj pl0 pln pt0 pt1 ptlist ptn usercmd userosm)
    
59.    (princ "快捷填充")
    
60.    (defun *Error* (msg)
    
61.      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
    
62.      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm) blipm (setvar "blipmode" blipm))
    
63.      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
    
64.    )
    
65.    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
    
66.    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE") blipm (getvar "blipmode"))
    
67.    (setvar "CMDECHO" 0)
    
68.      (progn
    
69.        (setvar "OSMODE" 6839)
    
70.        (setvar "blipmode" 0)
    
71.        (setq pt0 (getpoint "\n指定第一点: "))
    
72.        (if pt0
    
73.          (progn
    
74.            (setq ptlist nil)
    
75.            (setq pt1 pt0)
    
76.            (command ".pline" pt0 pt1 "")
    
77.            (setq pl0 (entlast))
    
78.            (while pt0
    
79.              (setq ptlist (cons pt0 ptlist))
    
80.              (setq ptn pt0)
    
81.              (setq pt0 (getpoint pt0 "\r下一个点[回车闭合] "))
    
82.              (if (or
    
83.                    (equal pt0 pt1)
    
84.                    (= pt0 nil)
    
85.                  )
    
86.                (setq pt0 nil)
    
87.                ""
    
88.              )
    
89.              (if pt0
    
90.                (progn
    
91.                  (command ".pline" ptn pt0 "")
    
92.                  (setq pln (entlast))
    
93.                  (command "pedit" pl0 "j" pln "" "")
    
94.                  (setq pl0 (entlast))
    
95.                  (redraw pl0 3)
    
96.                )
    
97.                (progn
    
98.                  (command ".pline" ptn pt1 "")
    
99.                  (command "pedit" pl0 "j" (entlast) "" "")
    
100.                )
     
101.              )                               ; end if
     
102.            )                               ; end while
     
103.            (setq pl0 (entlast))
     
104.            (command ".hatch" "" "" "" "l" "")
     
105.            (entdel pl0)
     
106.            (if (tblsearch "layer" "FILL")
     
107.              ""
     
108.              (command "layer" "New" "FILL" "c" "191" "FILL" "")
     
109.            )
     
110.            (command "change" (entlast) "" "P" "la" "FILL" "")
     
111.            (setq i 0)
     
112.            (if (setq obj (ssget "f" ptlist))
     
113.              (repeat (sslength obj)
     
114.                (redraw (ssname obj i))
     
115.                (setq i (+ i 1))
     
116.              )
     
117.              ""
     
118.            )
     
119.          )
     
120.          (prompt "取消")
     
121.        )
     
122.        (*Error* "")
     
123.      (princ)
     
124.    )
     
125. )
     

;;;;;;自动填充：ff；hhh <br /> (defun c:ff ( / *Error* blipm eedel i plw pp1 pp2 ppa ppb ptlist rden redent usercmd userosm)<br />    (princ "快捷填充")<br />    (defun *Error* (msg)<br />      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))<br />      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm))<br />      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))<br />    )<br />    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)<br />    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE"))<br />   (while<br />    (progn<br />      (setvar "CMDECHO" 0)<br />      (setvar "OSMODE" 6839) <br />      (setq blipm(getvar "blipmode"))<br />      (setvar "blipmode" 0)<br />      (setq pp1(getpoint "\n指定第一点:"))<br />      (setq pp2(getcorner pp1  "\r指定对角点:"))<br />      (if (or (= pp1 nil) (= pp2 nil)) ""<br />          (progn<br />      (setq ppa (list (car pp2)(cadr pp1)))<br />      (setq ppb(list (car pp1) (cadr pp2)))<br />      (setq ptlist ( list pp1 ppa pp2 ppb))<br />      (setq plw(getvar "plinewid"))<br />      (setvar "plinewid" 0)<br />      (command "pline" pp1 ppa   pp2  ppb "c")<br />      (setvar "plinewid" plw)<br />      (setq eedel(entlast))<br />      (if (tblsearch "layer" "FILL") ""<br />        (command "layer" "New" "FILL" "c" "191" "FILL" "")<br />      )<br />      (command "hatch"  "" "" "" "l" "")<br />      (command "change" (entlast) "" "P" "la" "FILL" "")<br />      (entdel eedel)<br />      (setvar "blipmode" blipm)<br />      (setq redent(ssget "f" ptlist))<br />        (if (= redent nil)  ""<br />         (progn<br />           (setq i 1)<br />          (setq rden (ssname redent 0))<br />           (while rden<br />           (redraw rden)<br />           (setq rden (ssname redent i))<br />           (setq i (+ i 1))<br />           )<br />         ) <br />       )  <br />     ))<br />    )<br /> (princ "\n*继续*")<br /> )<br />   (*Error* "")<br /> (princ)<br /> )<br /> <br /> ;;;;;;自动画边界填充<br /> (defun c:HHH ( / *Error* blipm i obj pl0 pln pt0 pt1 ptlist ptn usercmd userosm)<br />    (princ "快捷填充")<br />    (defun *Error* (msg)<br />      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))<br />      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm) blipm (setvar "blipmode" blipm))<br />      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))<br />    )<br />    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)<br />    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE") blipm (getvar "blipmode"))<br />    (setvar "CMDECHO" 0)<br />      (progn<br />        (setvar "OSMODE" 6839)<br />        (setvar "blipmode" 0)<br />        (setq pt0 (getpoint "\n指定第一点: "))<br />        (if pt0<br />          (progn<br />            (setq ptlist nil)<br />            (setq pt1 pt0)<br />            (command ".pline" pt0 pt1 "")<br />            (setq pl0 (entlast))<br />            (while pt0<br />              (setq ptlist (cons pt0 ptlist))<br />              (setq ptn pt0)<br />              (setq pt0 (getpoint pt0 "\r下一个点[回车闭合] "))<br />              (if (or<br />                    (equal pt0 pt1)<br />                    (= pt0 nil)<br />                  )<br />                (setq pt0 nil)<br />                ""<br />              )<br />              (if pt0<br />                (progn<br />                  (command ".pline" ptn pt0 "")<br />                  (setq pln (entlast))<br />                  (command "pedit" pl0 "j" pln "" "")<br />                  (setq pl0 (entlast))<br />                  (redraw pl0 3)<br />                )<br />                (progn<br />                  (command ".pline" ptn pt1 "")<br />                  (command "pedit" pl0 "j" (entlast) "" "")<br />                )<br />              )                               ; end if<br />            )                               ; end while<br />            (setq pl0 (entlast))<br />            (command ".hatch" "" "" "" "l" "")<br />            (entdel pl0)<br />            (if (tblsearch "layer" "FILL")<br />              ""<br />              (command "layer" "New" "FILL" "c" "191" "FILL" "")<br />            )<br />            (command "change" (entlast) "" "P" "la" "FILL" "")<br />            (setq i 0)<br />            (if (setq obj (ssget "f" ptlist))<br />              (repeat (sslength obj)<br />                (redraw (ssname obj i))<br />                (setq i (+ i 1))<br />              )<br />              ""<br />            )<br />          )<br />          (prompt "取消")<br />        )<br />        (*Error* "")<br />      (princ)<br />    )<br /> )<br />

忘记了是哪个大侠的程序了，在此表示感谢，分享下他的源码