动态调整图案填充比例的程序？

cj52000

各位好：
             想求一程序，就是图案填充后，然后可以动态调整其比例，就像“动态调整线型比例 ”一样，贴子如下http://bbs.mjtd.com/thread-84751-1-3.html，论坛里也有类似的程序，但是太复杂，我只是要单纯的调整填充比例，谢谢！

Wu_Enwu

看看隐藏了什么好东东

趣意人生

谢谢分享谢谢分享

zhangrunze

感谢分享~
学习了~

gzxl

是不是这样?

cj52000

回复 gzxl 的帖子

回gzxl兄，你发的论坛上有，是这样的，不过图案填充是我已经填充好了的，我只需要改变它的线型比例就好，谢谢！

cj52000

版主来看看呀

Gu_xl

回复 cj52000 的帖子
;;;动态调整填充比例 作者：Gu_xl

1. ;;;2007以上版本适用
   
2. 
   
3. 
   
4.   (defun c:dhatchscale (/ flag p1 p2 p3 en enline gr d scale oldscale newscale enl obj olderr myerr origin)
   
5.    (defun myerr(msg)
   
6.     (setq *error* olderr)
   
7.     (command "_.undo" "_b")
   
8.     (princ)
   
9.   )
   
10.   (setq olderr *error* *error* myerr )
    
11.   (command "_.undo" "m")
    
12.     (setq flag t)
    
13.   (while flag
    
14.     (setq en (entsel "\n选择填充："))
    
15.     (if (and en (= "HATCH" (cdr (assoc 0 (entget (car en))))))
    
16.       (setq flag nil)
    
17.       )
    
18.     )
    
19.   (setq obj (vlax-ename->vla-object (setq en (car en))))
    
20.   (vla-GetBoundingBox obj  'p2 'p3)
    
21.   (setq p2 (vlax-safearray->list p2)
    
22. p3 (vlax-safearray->list p3)
    
23. p1 (mapcar '(lambda (x) (* 0.5 x)) (mapcar '+ p2 p3))
    
24. )
    
25.   
    
26.   (setq d (* 0.1 (getvar "viewsize")))
    
27.   (setq scale (vla-get-PatternScale obj)
    
28. AssociativeHatch (vla-get-AssociativeHatch obj)
    
29. origin (vla-get-Origin obj)
    
30. oldscale scale)
    
31.   (entmake (list (cons 0 "line") (cons 62 2) (cons 10 p1) (cons 11 (polar p1 0 d))))
    
32.   (setq enline (entlast))
    
33.   (vla-copy obj)
    
34.   (setq obj (vlax-ename->vla-object (entlast)))
    
35. (vla-put-Origin obj origin)
    
36.   (vla-put-AssociativeHatch obj :vlax-false)
    
37.   (entdel en)
    
38.   
    
39.   (setq flag t)
    
40.   (while flag
    
41.     (setq gr (grread T 1))
    
42.     (if (= (car gr) 5)
    
43.       (progn
    
44. (setq p2 (cadr gr))
    
45. (entdel enline)
    
46. (entmake (list (cons 0 "line") (cons 62 2) (cons 10 p1) (cons 11 p2)))
    
47. (setq enline (entlast))
    
48. (setq newscale (* scale (/ (distance p1 p2) d)))
    
49. (if (not (equal newscale oldscale 0.01))
    
50.    (progn
    
51.      (vla-copy obj)
    
52.      (vla-delete obj)
    
53.      (setq obj (vlax-ename->vla-object (entlast)))
    
54. (vla-put-PatternScale obj newscale)
    
55. ;(vla-update obj)
    
56. (setq oldscale newscale)
    
57. )
    
58.    )
    
59.    )
    
60.       (progn
    
61. (entdel enline)
    
62.       (setq flag nil)
    
63.       )
    
64.       )
    
65.     )
    
66.   (vla-delete obj)
    
67.   (entdel en)
    
68.   (setq obj (vlax-ename->vla-object en))
    
69.   (vla-put-PatternScale obj newscale)
    
70.   ;(vla-update obj)
    
71. 
    
72.   (setq  *error*  olderr )
    
73.   (princ)
    
74.   )

;;;2007以上版本适用<br /> <br /> <br />   (defun c:dhatchscale (/ flag p1 p2 p3 en enline gr d scale oldscale newscale enl obj olderr myerr origin)<br />    (defun myerr(msg)<br />     (setq *error* olderr)<br />     (command "_.undo" "_b")<br />     (princ)<br />   )<br />   (setq olderr *error* *error* myerr )<br />   (command "_.undo" "m")<br />     (setq flag t)<br />   (while flag<br />     (setq en (entsel "\n选择填充："))<br />     (if (and en (= "HATCH" (cdr (assoc 0 (entget (car en))))))<br />       (setq flag nil)<br />       )<br />     )<br />   (setq obj (vlax-ename->vla-object (setq en (car en))))<br />   (vla-GetBoundingBox obj  'p2 'p3)<br />   (setq p2 (vlax-safearray->list p2)<br /> p3 (vlax-safearray->list p3)<br /> p1 (mapcar '(lambda (x) (* 0.5 x)) (mapcar '+ p2 p3))<br /> )<br />   <br />   (setq d (* 0.1 (getvar "viewsize")))<br />   (setq scale (vla-get-PatternScale obj)<br /> AssociativeHatch (vla-get-AssociativeHatch obj)<br /> origin (vla-get-Origin obj)<br /> oldscale scale)<br />   (entmake (list (cons 0 "line") (cons 62 2) (cons 10 p1) (cons 11 (polar p1 0 d))))<br />   (setq enline (entlast))<br />   (vla-copy obj)<br />   (setq obj (vlax-ename->vla-object (entlast)))<br /> (vla-put-Origin obj origin)<br />   (vla-put-AssociativeHatch obj :vlax-false)<br />   (entdel en)<br />   <br />   (setq flag t)<br />   (while flag<br />     (setq gr (grread T 1))<br />     (if (= (car gr) 5)<br />       (progn<br /> (setq p2 (cadr gr))<br /> (entdel enline)<br /> (entmake (list (cons 0 "line") (cons 62 2) (cons 10 p1) (cons 11 p2)))<br /> (setq enline (entlast))<br /> (setq newscale (* scale (/ (distance p1 p2) d)))<br /> (if (not (equal newscale oldscale 0.01))<br />    (progn<br />      (vla-copy obj)<br />      (vla-delete obj)<br />      (setq obj (vlax-ename->vla-object (entlast)))<br /> (vla-put-PatternScale obj newscale)<br /> ;(vla-update obj)<br /> (setq oldscale newscale)<br /> )<br />    )<br />    )<br />       (progn<br /> (entdel enline)<br />       (setq flag nil)<br />       )<br />       )<br />     )<br />   (vla-delete obj)<br />   (entdel en)<br />   (setq obj (vlax-ename->vla-object en))<br />   (vla-put-PatternScale obj newscale)<br />   ;(vla-update obj)<br /> <br />   (setq  *error*  olderr )<br />   (princ)<br />   )

xyz2009xyz

还是Gu_xl版主的好玩，呵呵！谢谢！

cj52000

回复 Gu_xl 的帖子

回Gu_xl版主，程序很好用，可能是我的CAD2010有问题，我新建一个图档，可以正常使用，如果我打开已经画好的图档，那条控制线就飞得好远，而且也动不了，再次感谢您的热心！

Gu_xl

回复 cj52000 的帖子

控制线就飞得好远，可能是你的ucs的问题！你可以自己修改一下，用函数trans将grread得到的p2坐标转到wcs，示例：(setq p2 (trans p2 1 0))

cj52000

回复 Gu_xl 的帖子

不怕版主见笑，我刚入门是个菜乌，不会改啊

Gu_xl

回复 cj52000 的帖子

或者你在程序开始加上这段代码，将坐标系改为wcs
(command "_ucs" "w")