chang1622 发表于 2014-5-18 17:52:04

求教动态更改填充比例

本帖最后由 chang1622 于 2014-5-18 17:56 编辑

动态更改填充比例，论坛上版主XYP1964发过此效果图，但不会用！
谁能帮帮忙发个源码，图案为ANI31角度固定只改比例

xyp1964 发表于 2019-1-23 18:45:52

(defun c:ddbl (/ s1)
(if (and (setq s1 (entsel "\n选择: "))
           (= (xyp-get-dxf 0 (car s1)) "HATCH")
      )
    (xyp-Grread-Change s1 "填充角度" 52 3)
)
(princ)
)

qmqyqj 发表于 2019-11-25 10:49:42

edata 发表于 2014-5-18 22:38
院长的都是精品，学习的典范。
有时候模仿院长的演示也能锻炼锻炼思维方式。
动态填充比例调整，仅比例。 ...

想问下，这个显示的文字字体怎么修改，在高版本的CAD中使用，中文会显示为 问号❓

qmqyqj 发表于 2019-11-20 22:42:51

edata 发表于 2014-5-18 22:38
院长的都是精品，学习的典范。
有时候模仿院长的演示也能锻炼锻炼思维方式。
动态填充比例调整，仅比例。 ...

windows10系统下， “当前比例”显示 为 ？？？？号

edata 发表于 2014-5-18 22:38:31

院长的都是精品，学习的典范。
有时候模仿院长的演示也能锻炼锻炼思维方式。
动态填充比例调整，仅比例。
我的演示：



代码部分（未加出错程序，如果想放弃调整输入s加空格，输入精准比例s加比例（如s100） s后不要空格哦，切记）
;;动态填充比例(only patternscale)
;;2014年5月18日
;;code by edata @mjtd
(defun c:tt(/ C_SCALE DS ENT GR MPT OBJ P1 P3 SCREEN_H SCREEN_PT SS TEXT_DS X Y loop scale_p)
(vl-load-com)
(vla-StartUndoMark (vla-get-activedocument(vlax-get-acad-object)))
;;Get viewpt Sub function from bbs.mjtd.com
   (defun viewpt(/ a b c d x)
    (setq b (getvar "viewsize") c (car (getvar "screensize")) d (cadr (getvar "screensize"))
          a (* b (/ c d)) x (setq x (getvar "viewctr")) x (trans x 1 2) c (list (- (car x)(/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
          d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) c (trans c 2 1) d (trans d 2 1)
    )
    (list c d)
)
;;End Sub function

;;Start main function
    (if(and (setq ss(ssget ":S" '((0 . "hatch"))))
    (setq ent(ssname ss 0))
    (car(list t (redraw ent 3))))
    (progn
      (setq obj (vlax-ename->vla-object ent)
      screen_pt(viewpt)
      screen_h(abs(- (cadr(cadr screen_pt))(cadr(car screen_pt))))
      loop t)
      (vla-GetBoundingBox obj 'p1 'p3)
      (setq p1 (vlax-safearray->list p1)
      p3 (vlax-safearray->list p3)
      mpt(mapcar '(lambda(x y)(*(+ x y ) 0.5)) p1 p3)
      c_scale(vla-get-patternscale obj)
      text_ds(vlax-ename->vla-object(entmakex (list '(0 . "TEXT")(cons 62 4) (cons 1 (strcat "当前比例为: "(rtos c_scale 2)) ) (cons 10 mpt) (cons 40 (* screen_h 0.04))))))
      (prompt "\n移动鼠标或输入S比例数字(如s100):")
      (while (and loop (setq gr(grread t 15 0))(not (or(= (car gr) 3)(= (car gr) 25)(= (car gr) 11)(equal gr '(2 13))(equal gr '(2 32)))))
(cond
    ((= (car gr) 5)(setq p1(cadr gr))   
   (if(>(setq ds(distance mpt p1))0)(vla-put-patternscale obj (* ds 0.1)))
   ;(vla-put-patternangle obj (angle mpt p1));改角度
   (setq screen_pt(viewpt)
   screen_h(abs(- (cadr(cadr screen_pt))(cadr(car screen_pt)))))
   (vla-put-insertionpoint text_ds (vlax-3d-point p1))
   (vla-put-height text_ds (* screen_h 0.04))
   (vla-put-textstring text_ds (strcat "当前比例为: "(rtos (* ds 0.1) 2)))
   (vla-update obj)
   (vla-update text_ds)   
   (redraw)   
   (grdraw mpt p1 1 3)   
   )
    ((equal gr '(2 115)) (setq loop nil)(if(setq scale_p(getreal "\n输入比例:s"))(vla-put-patternscale obj scale_p)(vla-put-patternscale obj c_scale)))
    )
(entmod (entget ent))
(entmod (entget (vlax-vla-object->ename text_ds)))
)
      (and text_ds(vla-delete text_ds))
      (and text_ds(vlax-release-object text_ds))
      (and obj(vlax-release-object obj))
      )
    )
(vla-EndUndoMark (vla-get-activedocument(vlax-get-acad-object)))
(redraw)
(princ)
)
(prompt "loading dynamic patternscale code by edata,Command istt")
(princ)

ysq101 发表于 2014-5-19 12:38:12

版主牛叉啊。。。学习学习。。。一直想写有关于动态的玩意。无奈资质太差

chang1622 发表于 2014-5-19 13:44:30

非常好！谢谢edata帮助啊。。。学习学习。。。

pxt2001 发表于 2014-7-20 12:03:05

这个程序很强大，收藏了。

xieyanghui 发表于 2014-7-21 02:47:48

角度可否支持f8正交呀！

hooboxu 发表于 2015-2-10 23:27:00

能否出一个可以移动填充图案啊?

yoyoho 发表于 2015-2-11 23:05:42

感谢 edata 分享程序,不错喔!

lxg3443 发表于 2015-5-15 18:35:46

在我这里显示的那句“当前比例为:”全部为   ？？？？？？ 该怎么办啊

894560869 发表于 2015-9-21 21:15:24

真厉害啊，谢谢分享了
页: [1] 2
查看完整版本: 求教动态更改填充比例