求助 外部插入图块动态显示缩放

啵浪鼓

从外部插入带属性的图框(block)时，有没有办法像画矩形一样，输出左下角点，另一角点随着鼠标的移动，图框实时显示大小，以方便知道图框的大小适合范围后再点另一角点！

664571221

Gu_xl 发表于 2011-5-13 21:05
回复 啵浪鼓 的帖子

类似的程序我以前好像在编程申请里发过的，这里再发一下！

你好g版，能不能弄一个块图元 在基地处批量缩放   可以输入比例或则动态缩放

依然小小鸟

highflybird 发表于 2011-5-14 01:21
以下代码仅供参考

可以实习 X Y不同比例 缩放或者扩大吗

不语勿语

谢谢G版分享

alwtyp

插入圖塊時不用指定大小，用PAUSE代替

啵浪鼓

楼上的方法不显，没法像画矩形一样实时显示
曾经见过别人用过这程序，点右下点后开始实时显示大小，可惜没有程序！

狂刀lxx

1 ： 1插入后再scale，在里面pause，是可以的。以上步骤也可以整合到lisp里面去

啵浪鼓

回复 狂刀lxx 的帖子

下面二种方法，第二种先输比例的再放pause的不行
第一种可以实现实时显示,但是点了左下角点后，再去点右上角的位置，鼠标轻轻移动一下，图框飞得老远，图框超大！
我想问的是，有没有办法控制图框的左下角点和右上角点，就是画矩形那样，点哪图框的比例就依据左下角点到右上角点自动缩放比例，而且是实时显示图框比例变化过程！

命令: (command "insert" "A3" (getpoint) pause)
*取消*

命令: (command "insert" "A3" "S" pause)
指定第二点: 指定插入点或
[比例(S)/X/Y/Z/旋转(R)/预览比例(PS)/PX/PY/PZ/预览旋转(PR)]:

啵浪鼓

无法实现么?

highflybird

(getcorner (getpoint "\n请输入插入点:") "\n请输入对角点:")

哦，没细看，还要动态，是么？可以用grread

Gu_xl

回复 啵浪鼓 的帖子

类似的程序我以前好像在编程申请里发过的，这里再发一下！

1. ;;;动态插图块，编制：  2010.12.14 By Gu_xl
   
2. (defun tk(tkname p1 p2 flag /  pp1 pp2 v h v1 h1 xscale yscale)
   
3.   
   
4.   (setq pp1 (mapcar '(lambda (x)(apply 'min x))  (apply 'mapcar (cons 'list (list p1 p2))))
   
5.         pp2 (mapcar '(lambda (x)(apply 'max x))  (apply 'mapcar (cons 'list (list p1 p2))))
   
6.         v (- (cadr pp2) (cadr pp1))
   
7.         h (- (car pp2) (car pp1))
   
8.         )
   
9.   (if (> h v)
   
10.       (setq v (/ h (/ 420. 297.)))
    
11.       (setq h (/ v  (/ 420. 297.)))
    
12.       )
    
13. (vla-InsertBlock ms (vlax-3d-point pp1) tkname 1 1 1 0)
    
14.   (setq en (entlast))
    
15.   (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)
    
16.   (setq pl (mapcar 'vlax-safearray->list (list p1 p2)))
    
17.   (setq p1 (vlax-safearray->list p1)
    
18.         p2 (vlax-safearray->list p2)
    
19.         v1 (- (cadr p2) (cadr p1))
    
20.         h1 (- (car p2) (car p1))
    
21.         )
    
22.   (cond ((and (> h v) (>= h1 v1))
    
23.           (setq        xscale (/ h h1)
    
24.                 yscale (/ v v1)
    
25.                 rot 0
    
26.           )
    
27.         )
    
28.         ((and (> h v) (>= v1 h1))
    
29.           (setq        yscale (/ h v1)
    
30.                 xscale (/ v h1)
    
31.                 rot (- (/ pi 2))          )
    
32.         )
    
33.         ((and (> v h) (>= v1 h1))
    
34.           (setq        xscale (/ v v1)
    
35.                 yscale (/ h h1)
    
36.                 rot 0
    
37.           )
    
38.         )
    
39.         ((and (> v h) (>= h1 v1))
    
40.           (setq        yscale (/ v h1)
    
41.                 xscale (/ h v1)
    
42.                 rot (/ pi 2)          )
    
43.         )
    
44.         )
    
45.   (entdel en)
    
46. (vla-InsertBlock ms (vlax-3d-point pp1) tkname xscale yscale 1  rot)
    
47.   (setq en (entlast))
    
48.     (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)
    
49.   (setq pl (mapcar 'vlax-safearray->list (list p1 p2)))
    
50.   (setq p1 (vlax-safearray->list p1)
    
51. p2 (vlax-safearray->list p2)
    
52. )
    
53.   (command "move" en "" p1 pp1)
    
54.   (setq obj (vlax-ename->vla-object en))
    
55.   (if (and flag (= :vlax-true (vla-get-HasAttributes obj)))
    
56.     (command "eattedit" en)
    
57.     )
    
58. (princ)
    
59.   )
    
60. (defun c:tk (/ name p1 flag gr oldp2 en ms)
    
61. (vl-load-com)
    
62.    (setq oldcmdecho (getvar "cmdecho"))
    
63.   (setq attreq (getvar "attreq"))
    
64.   (setvar "cmdecho" 0)
    
65.   (setvar "attreq" 0)
    
66. (setq ms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
    
67. (setq name (getvar "insname"))
    
68.   (setq name (getstring (strcat "\n 输入要插入的图框名称<" name ">：")))
    
69.   (if (= "" name) (setq name (getvar "insname")))
    
70.   (if (not (tblsearch "BLOCK" name)) (setq name (findfile (setq name1 (strcat name ".dwg")))))
    
71.   (if (not name) (setq name (getfiled "选择要插入的图形文件" name1 "dwg" 4)))
    
72.   (if (not name) (exit))
    
73. 
    
74.   (setq p1 (getpoint "\图框插入角点："))
    
75.   (setq flag t)
    
76.   (while (and p1 flag)
    
77.     (setq gr (grread t 2))
    
78.     (if (= 5 (car gr))
    
79.       (progn
    
80.         (setq p2 (cadr gr))
    
81.         (setq d (* 0.01 (getvar "viewsize"))) ;_ 最小移动间距
    
82.         (if (and (not (equal (car p1) (car p2) 0.001))
    
83.                  (not (equal (cadr p1) (cadr p2) 0.001))
    
84.                  (or (null oldp2)
    
85.                      (> (distance p2 oldp2) d)
    
86.                  )
    
87.             )
    
88.           (progn
    
89.             (setq oldp2 p2)
    
90.             (if en (entdel en))
    
91.             (tk name  p1 p2 nil)
    
92.             (setq en (entlast))
    
93.             )
    
94.           )
    
95.         
    
96.         )
    
97.       (setq flag nil)
    
98.       )
    
99.     )
    
100.   (if (= :vlax-true (vla-get-HasAttributes (vlax-ename->vla-object en)))
     
101.     (command "eattedit" en)
     
102.     )
     
103. (setvar "insname" (vl-filename-base name))
     
104.   (setvar "cmdecho" oldcmdecho)
     
105.   (setvar "attreq" attreq)
     
106.   (princ)
     
107.   )
     

;;;动态插图块，编制：  2010.12.14 By Gu_xl<br /> (defun tk(tkname p1 p2 flag /  pp1 pp2 v h v1 h1 xscale yscale)<br />   <br />   (setq pp1 (mapcar '(lambda (x)(apply 'min x))  (apply 'mapcar (cons 'list (list p1 p2))))<br />         pp2 (mapcar '(lambda (x)(apply 'max x))  (apply 'mapcar (cons 'list (list p1 p2))))<br />         v (- (cadr pp2) (cadr pp1))<br />         h (- (car pp2) (car pp1))<br />         )<br />   (if (> h v)<br />       (setq v (/ h (/ 420. 297.)))<br />       (setq h (/ v  (/ 420. 297.)))<br />       )<br /> (vla-InsertBlock ms (vlax-3d-point pp1) tkname 1 1 1 0)<br />   (setq en (entlast))<br />   (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)<br />   (setq pl (mapcar 'vlax-safearray->list (list p1 p2)))<br />   (setq p1 (vlax-safearray->list p1)<br />         p2 (vlax-safearray->list p2)<br />         v1 (- (cadr p2) (cadr p1))<br />         h1 (- (car p2) (car p1))<br />         )<br />   (cond ((and (> h v) (>= h1 v1))<br />           (setq        xscale (/ h h1)<br />                 yscale (/ v v1)<br />                 rot 0<br />           )<br />         )<br />         ((and (> h v) (>= v1 h1))<br />           (setq        yscale (/ h v1)<br />                 xscale (/ v h1)<br />                 rot (- (/ pi 2))          )<br />         )<br />         ((and (> v h) (>= v1 h1))<br />           (setq        xscale (/ v v1)<br />                 yscale (/ h h1)<br />                 rot 0<br />           )<br />         )<br />         ((and (> v h) (>= h1 v1))<br />           (setq        yscale (/ v h1)<br />                 xscale (/ h v1)<br />                 rot (/ pi 2)          )<br />         )<br />         )<br />   (entdel en)<br /> (vla-InsertBlock ms (vlax-3d-point pp1) tkname xscale yscale 1  rot)<br />   (setq en (entlast))<br />     (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)<br />   (setq pl (mapcar 'vlax-safearray->list (list p1 p2)))<br />   (setq p1 (vlax-safearray->list p1)<br /> p2 (vlax-safearray->list p2)<br /> )<br />   (command "move" en "" p1 pp1)<br />   (setq obj (vlax-ename->vla-object en))<br />   (if (and flag (= :vlax-true (vla-get-HasAttributes obj)))<br />     (command "eattedit" en)<br />     )<br /> (princ)<br />   )<br /> (defun c:tk (/ name p1 flag gr oldp2 en ms)<br /> (vl-load-com)<br />    (setq oldcmdecho (getvar "cmdecho"))<br />   (setq attreq (getvar "attreq"))<br />   (setvar "cmdecho" 0)<br />   (setvar "attreq" 0)<br /> (setq ms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))<br /> (setq name (getvar "insname"))<br />   (setq name (getstring (strcat "\n 输入要插入的图框名称<" name ">：")))<br />   (if (= "" name) (setq name (getvar "insname")))<br />   (if (not (tblsearch "BLOCK" name)) (setq name (findfile (setq name1 (strcat name ".dwg")))))<br />   (if (not name) (setq name (getfiled "选择要插入的图形文件" name1 "dwg" 4)))<br />   (if (not name) (exit))<br /> <br />   (setq p1 (getpoint "\图框插入角点："))<br />   (setq flag t)<br />   (while (and p1 flag)<br />     (setq gr (grread t 2))<br />     (if (= 5 (car gr))<br />       (progn<br />         (setq p2 (cadr gr))<br />         (setq d (* 0.01 (getvar "viewsize"))) ;_ 最小移动间距<br />         (if (and (not (equal (car p1) (car p2) 0.001))<br />                  (not (equal (cadr p1) (cadr p2) 0.001))<br />                  (or (null oldp2)<br />                      (> (distance p2 oldp2) d)<br />                  )<br />             )<br />           (progn<br />             (setq oldp2 p2)<br />             (if en (entdel en))<br />             (tk name  p1 p2 nil)<br />             (setq en (entlast))<br />             )<br />           )<br />         <br />         )<br />       (setq flag nil)<br />       )<br />     )<br />   (if (= :vlax-true (vla-get-HasAttributes (vlax-ename->vla-object en)))<br />     (command "eattedit" en)<br />     )<br /> (setvar "insname" (vl-filename-base name))<br />   (setvar "cmdecho" oldcmdecho)<br />   (setvar "attreq" attreq)<br />   (princ)<br />   )<br />

啵浪鼓

回复 Gu_xl 的帖子

Gu_xl版主的程序挺好，非常感谢！论坛搜索功能不太好用，搜的东西往往可能一个字的误差就搜不出来！纠结的很！

您的程序有3个问题请教一下：
1，输入图框名称的第一个字时，光标怎么自动跑到字的前面去了，本来想输"a3"，结果成"3a"，如果想要正确的需在输第一个字时用鼠标点到a的后面输3,这样多了一步点鼠标的动作了
以为是跟我的程序冲突，试过关闭cad从开还是一样的效果.
命令: tk
输入要插入的图框名称<>：3a 图框插入角点：*取消*

经确认，getstring命令本身是没有问题的：
命令: (getstring)
a3
"a3"

2，程序第一次运行一切正常，第二次以后都会出现 "INTERSECT 所选对象太多"
命令: TK
输入要插入的图框名称<>：A3
图框插入角点：
命令:
命令: E ERASE 找到 1 个
命令: TK
输入要插入的图框名称<A3>： 图框插入角点：
INTERSECT 所选对象太多
INTERSECT 所选对象太多

3，插入图框时动态显示闪的很厉害，是不是受grread这个函数本身的制约？以前看到别人用的程序动态显示就像画线一般!可能是别的语言编写的吧，lisp也许达不到这中效果!

highflybird

以下代码仅供参考

1. (defun c:test (/ ent obj InsPnt pt1 pt2 Pa Pb Vec)
   
2.   (setq cmd (getvar "CMDECHO"))
   
3.   (setvar "CMDECHO" 0)
   
4.   (command "DDINSERT" (setq InsPnt (getpoint "\n输入插入点:")))
   
5.   (setq ent (entlast))
   
6.   (setq obj (vlax-ename->vla-object ent))
   
7.   (vla-getboundingbox obj 'pa 'pb)
   
8.   (setq pt1 (vlax-safearray->list pa)
   
9. pt2 (vlax-safearray->list pb)
   
10. Vec (mapcar '- pt2 pt1)
    
11.   )
    
12.   (vla-move obj pa (vlax-3d-point InsPnt))
    
13.   (command ".SCALE" "L" "" InsPnt "R" pt1 pt2 pause)
    
14.   (setvar "CMDECHO" cmd)
    
15.   (princ)
    
16. )

(defun c:test (/ ent obj InsPnt pt1 pt2 Pa Pb Vec)<br />   (setq cmd (getvar "CMDECHO"))<br />   (setvar "CMDECHO" 0)<br />   (command "DDINSERT" (setq InsPnt (getpoint "\n输入插入点:")))<br />   (setq ent (entlast))<br />   (setq obj (vlax-ename->vla-object ent))<br />   (vla-getboundingbox obj 'pa 'pb)<br />   (setq pt1 (vlax-safearray->list pa)<br /> pt2 (vlax-safearray->list pb)<br /> Vec (mapcar '- pt2 pt1)<br />   )<br />   (vla-move obj pa (vlax-3d-point InsPnt))<br />   (command ".SCALE" "L" "" InsPnt "R" pt1 pt2 pause)<br />   (setvar "CMDECHO" cmd)<br />   (princ)<br /> )