明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 10488|回复: 26

[已解答] 求一个快速填充的程序

  [复制链接]
发表于 2014-6-16 09:14 | 显示全部楼层 |阅读模式
2明经币
本帖最后由 fire9527 于 2014-6-16 09:16 编辑

使用要求:
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

最佳答案

发表于 2014-6-16 09:14 | 显示全部楼层
  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.   )

评分

参与人数 1明经币 +1 收起 理由
lucas_3333 + 1 热心助人奖

查看全部评分

回复

使用道具 举报

发表于 2014-6-16 09:54 | 显示全部楼层
这个很容易啊!将命令行转成代码即可!
  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. )

点评

G版真是热心人~~~赞~  发表于 2014-6-16 11:26
回复

使用道具 举报

发表于 2014-6-16 10:26 | 显示全部楼层
G版,第一次运行时怎么有这个提示呢?
未知的图案名。填充图案太密
图案填充间距太密,或短划尺寸太小。 nil


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

点评

提示已经很明确了啊!  发表于 2014-6-16 11:53
回复

使用道具 举报

 楼主| 发表于 2014-6-16 12:56 | 显示全部楼层
edata 发表于 2014-6-16 12:35

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

使用道具 举报

发表于 2014-6-16 13:02 | 显示全部楼层
同样的矩形和填充比例不匹配的时候,填充会失败哦。。。
这个是填充保护机制。
回复

使用道具 举报

 楼主| 发表于 2014-6-16 13:13 | 显示全部楼层
edata 发表于 2014-6-16 13:02
同样的矩形和填充比例不匹配的时候,填充会失败哦。。。
这个是填充保护机制。

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

使用道具 举报

发表于 2014-6-16 17:57 | 显示全部楼层
  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.   )
回复

使用道具 举报

 楼主| 发表于 2014-6-16 23:01 | 显示全部楼层
edata 发表于 2014-6-16 17:57

错误: 参数太多

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

使用道具 举报

发表于 2014-6-17 09:59 | 显示全部楼层
  1. ;;;;;;自动填充:ff;hhh
  2. (defun c:ff ( / *Error* blipm eedel i plw pp1 pp2 ppa ppb ptlist rden redent usercmd userosm)
  3.    (princ "快捷填充")
  4.    (defun *Error* (msg)
  5.      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
  6.      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm))
  7.      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  8.    )
  9.    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
  10.    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE"))
  11.   (while
  12.    (progn
  13.      (setvar "CMDECHO" 0)
  14.      (setvar "OSMODE" 6839)
  15.      (setq blipm(getvar "blipmode"))
  16.      (setvar "blipmode" 0)
  17.      (setq pp1(getpoint "\n指定第一点:"))
  18.      (setq pp2(getcorner pp1  "\r指定对角点:"))
  19.      (if (or (= pp1 nil) (= pp2 nil)) ""
  20.          (progn
  21.      (setq ppa (list (car pp2)(cadr pp1)))
  22.      (setq ppb(list (car pp1) (cadr pp2)))
  23.      (setq ptlist ( list pp1 ppa pp2 ppb))
  24.      (setq plw(getvar "plinewid"))
  25.      (setvar "plinewid" 0)
  26.      (command "pline" pp1 ppa   pp2  ppb "c")
  27.      (setvar "plinewid" plw)
  28.      (setq eedel(entlast))
  29.      (if (tblsearch "layer" "FILL") ""
  30.        (command "layer" "New" "FILL" "c" "191" "FILL" "")
  31.      )
  32.      (command "hatch"  "" "" "" "l" "")
  33.      (command "change" (entlast) "" "P" "la" "FILL" "")
  34.      (entdel eedel)
  35.      (setvar "blipmode" blipm)
  36.      (setq redent(ssget "f" ptlist))
  37.        (if (= redent nil)  ""
  38.         (progn
  39.           (setq i 1)
  40.          (setq rden (ssname redent 0))
  41.           (while rden
  42.           (redraw rden)
  43.           (setq rden (ssname redent i))
  44.           (setq i (+ i 1))
  45.           )
  46.         )
  47.       )  
  48.     ))
  49.    )
  50. (princ "\n*继续*")
  51. )
  52.   (*Error* "")
  53. (princ)
  54. )

  55. ;;;;;;自动画边界填充
  56. (defun c:HHH ( / *Error* blipm i obj pl0 pln pt0 pt1 ptlist ptn usercmd userosm)
  57.    (princ "快捷填充")
  58.    (defun *Error* (msg)
  59.      (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,*EXIT*,")))(princ))
  60.      (and usercmd (setvar "CMDECHO" usercmd) userosm (setvar "OSMODE" userosm) blipm (setvar "blipmode" blipm))
  61.      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  62.    )
  63.    (setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))(vla-StartUndoMark *DOC)
  64.    (setq usercmd (getvar "CMDECHO") userosm (getvar "OSMODE") blipm (getvar "blipmode"))
  65.    (setvar "CMDECHO" 0)
  66.      (progn
  67.        (setvar "OSMODE" 6839)
  68.        (setvar "blipmode" 0)
  69.        (setq pt0 (getpoint "\n指定第一点: "))
  70.        (if pt0
  71.          (progn
  72.            (setq ptlist nil)
  73.            (setq pt1 pt0)
  74.            (command ".pline" pt0 pt1 "")
  75.            (setq pl0 (entlast))
  76.            (while pt0
  77.              (setq ptlist (cons pt0 ptlist))
  78.              (setq ptn pt0)
  79.              (setq pt0 (getpoint pt0 "\r下一个点[回车闭合] "))
  80.              (if (or
  81.                    (equal pt0 pt1)
  82.                    (= pt0 nil)
  83.                  )
  84.                (setq pt0 nil)
  85.                ""
  86.              )
  87.              (if pt0
  88.                (progn
  89.                  (command ".pline" ptn pt0 "")
  90.                  (setq pln (entlast))
  91.                  (command "pedit" pl0 "j" pln "" "")
  92.                  (setq pl0 (entlast))
  93.                  (redraw pl0 3)
  94.                )
  95.                (progn
  96.                  (command ".pline" ptn pt1 "")
  97.                  (command "pedit" pl0 "j" (entlast) "" "")
  98.                )
  99.              )                               ; end if
  100.            )                               ; end while
  101.            (setq pl0 (entlast))
  102.            (command ".hatch" "" "" "" "l" "")
  103.            (entdel pl0)
  104.            (if (tblsearch "layer" "FILL")
  105.              ""
  106.              (command "layer" "New" "FILL" "c" "191" "FILL" "")
  107.            )
  108.            (command "change" (entlast) "" "P" "la" "FILL" "")
  109.            (setq i 0)
  110.            (if (setq obj (ssget "f" ptlist))
  111.              (repeat (sslength obj)
  112.                (redraw (ssname obj i))
  113.                (setq i (+ i 1))
  114.              )
  115.              ""
  116.            )
  117.          )
  118.          (prompt "取消")
  119.        )
  120.        (*Error* "")
  121.      (princ)
  122.    )
  123. )
忘记了是哪个大侠的程序了,在此表示感谢,分享下他的源码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

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

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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