鱼与熊掌 发表于 2014-11-3 19:16:54

匹配填充,稍微加强版.

本帖最后由 鱼与熊掌 于 2014-11-22 10:52 编辑


   ;匹配填充修正加强版,调用一部分明经别人的代码,加入自定义图元填充的支持.
   ;更正选择方式,可以用选择对象来填充.如果要用点选直接空格就进入点选模式.
   ;BY 鱼与熊掌 QQ:775452144
(prompt
"匹配填充，命令HH，BY鱼与熊掌，2014.11.22.加入图层匹配。"
)
(defun c:hh(/ e en key n p ss tc_ang tc_col tc_e tc_la tc_name tc_scle tc_vlae)
(cxsta)
(vl-load-com)
(setq en (entlast))
(if (setq tc_e (car (entsel "\n选择填充源图案:")))
    (progn
      (IF (= (CDR (ASSOC 0 (ENTGET TC_E))) "HATCH")
(PROGN
   (setq tc_vlae (vlax-ename->vla-object tc_e)
tc_name (vla-get-patternname tc_vlae)
tc_scle (vla-get-patternscale tc_vlae)
tc_ang (vla-get-patternangle tc_vlae)
tc_la (vla-get-layer tc_vlae)
tc_col (vla-get-color tc_vlae)
   )
   (if (= "_USER" tc_name)
   (command "bhatch"
       "p"
       "U"
       (* 180 (/ tc_ang pi))
       tc_scle
       "y"
       ""
   )
   (command "bhatch"
       "p"
       tc_name
       tc_scle
       (* 180 (/ tc_ang pi))
       ""
   )
   )
   (thpanduan)
   (if (setq ss (cx-en-ss en))
   (progn
       (cx-gs ss tc_col)
       (repeat (setq n (sslength ss))
(vla-put-layer
    (vlax-ename->vla-object (ssname ss (setq n (1- N))))
    tc_la
)
       )
   )
   )
)
      )
    )
    (PROMPT "选择的不是填充\n")
)
(cxend)
)
   ;api接口 填充判断
(defun thpanduan ()
(if (setq ss (ssget))
    (command "bhatch" "s" ss "" "") ;如果选择集不为空，则执行对象填充
    (progn    ;如果选择集为空，则执行点选命令
      (prompt "\n请拾取填充内部点：\n")
      (command "bhatch" pause)
      (while (> (getvar "CMDACTIVE") 0) (command PAUSE))
    )
)
)
   ;返回en之后的选择集
(defun cx-en-ss (en / ss)
(if en
    (progn
      (setq ss (ssadd))
      (while (entnext en)
(setq ss (ssadd (entnext en) ss))
(setq en (entnext en))
      )
      (if (> (sslength ss) 0)
ss
nil
      )
    )
)
)
(defun cx-gs (en clo / en clo)
(cond
    ((= (type en) 'ENAMe)
   (vla-put-Color (vlax-ename->vla-object en) clo)
    )
    ((= (type en) 'PICKSET)
   (repeat (setq i (sslength en))
       (vla-put-Color
(vlax-ename->vla-object (ssname en (setq i (1- i))))
clo
       )
   )
    )
    ((= (type en) 'VLA-OBJECT)
   (vla-put-Color en clo)
    )
)
)

(defun cxsta ()
(setvar "cmdecho" 0)   ; 关闭命令响应
(setq $orr *error*)
(setq *error* #err2)   ; 当程序出错时就会执行#err函数
(command ".UNDO" "BE"); 设置UNDO起点
)
(defun cxend ()
(command ".UNDO" "E")   ; 设置UNDO终点
(setq *error* $orr)
(setvar "osmode" 15359)
(princ)
)
;;; 出错处理函数
(defun #err2 (s)
(command ".UNDO" "E")   ; 设置UNDO终点
(redraw name1 4)
(redraw name2 4)
(princ)
(setq *error* $orr)
)


KO你 发表于 2018-12-5 22:50:13

楼主，我发现(用户定义填充)，本来是单向填充的变成双向填充了，能否再优化一下。谢谢

水仙的错 发表于 2019-9-14 18:15:58

不错的源码，支持下

llsheng_73 发表于 2014-11-3 19:37:06

沙发.........坐下慢慢看

鱼与熊掌 发表于 2014-11-3 19:44:06

llsheng_73 发表于 2014-11-3 19:37 static/image/common/back.gif
沙发.........坐下慢慢看

73哥客气了,我这个代码你看一眼就可以了

emk 发表于 2014-11-3 19:46:02

呵呵，地板支持

spp_wall 发表于 2014-11-3 19:54:27

本帖最后由 spp_wall 于 2014-11-3 20:01 编辑

支持支持！！！！！！！

sicky111 发表于 2014-11-3 21:03:36

命令: hh

选择填充源图案:; 错误: *error* 函数中出错参数类型错误: lentityp nil

tianyi1230 发表于 2014-11-4 19:19:54

这个也不错！可以参考严大师的！继承填充

hooboxu 发表于 2014-11-22 00:05:42

请问可以继承 原图案的层和颜色吗？

鱼与熊掌 发表于 2014-11-22 00:15:09

hooboxu 发表于 2014-11-22 00:05 static/image/common/back.gif
请问可以继承 原图案的层和颜色吗？

颜色已经继承了，加个图层也不是大问题

鱼与熊掌 发表于 2014-11-22 10:53:11

hooboxu 发表于 2014-11-22 00:05 static/image/common/back.gif
请问可以继承 原图案的层和颜色吗？

加入图层匹配
页: [1] 2
查看完整版本: 匹配填充,稍微加强版.