把"框选自动调出图框的程序"完善一下

bai2000

http://bbs.mjtd.com/thread-84595-2-1.html   上Gu_xl 的源码挺好，那位大哥能完善一下：1、可以连续插入？2、同时长宽的比例强制是图纸长宽（420/297）的比例？同时在框选的是横向时插入正常图框；框选的是竖向是把图框旋转-90.（竖向图框）3、是副能实现完毕后自动弹出图框中属性对话框，以便填写：图名、图号、日期等

vodoo

我用的是VBA

xiaxiang

用这个试试

ljttjl

bai2000

楼上的是卖程序的，这里可能不欢迎的

Gu_xl

1. ;;;(tk 图块名) 2010.12.14 By Gu_xl
   
2. (defun tk(tkname p1 p2 /  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.   (command "insert" tkname pp1 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 -90
    
32.           )
    
33.         )
    
34.         ((and (> v h) (>= v1 h1))
    
35.           (setq        xscale (/ v v1)
    
36.                 yscale (/ h h1)
    
37.                 rot 0
    
38.           )
    
39.         )
    
40.         ((and (> v h) (>= h1 v1))
    
41.           (setq        yscale (/ v h1)
    
42.                 xscale (/ h v1)
    
43.                 rot 90
    
44.           )
    
45.         )
    
46.         )
    
47.   (entdel en)
    
48.   (command "insert" tkname pp1 xscale yscale rot)
    
49.   (setq en (entlast))
    
50.     (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)
    
51.   (setq pl (mapcar 'vlax-safearray->list (list p1 p2)))
    
52.   (setq p1 (vlax-safearray->list p1)
    
53. p2 (vlax-safearray->list p2)
    
54. )
    
55.   (command "move" en "" p1 pp1)
    
56.   (setq obj (vlax-ename->vla-object en))
    
57.   (if (= :vlax-true (vla-get-HasAttributes obj))
    
58.     (command "eattedit" en)
    
59.     )
    
60. (princ)
    
61.   )
    
62. ;;;测试
    
63. (defun c:tk()
    
64.   (setq oldcmdecho (getvar "cmdecho"))
    
65.   (setq attreq (getvar "attreq"))
    
66.   (setvar "cmdecho" 0)
    
67.   (setvar "attreq" 0)
    
68.   (setq blkname (getstring "\n输入要插入的图框名称："))
    
69.   (while (and (setq p1 (getpoint "\n插入图框角点："))
    
70.               (setq p2 (GETCORNER p1 "图框另一角点")
    
71.               )
    
72.          )
    
73.   (tk blkname p1 p2)
    
74.     )
    
75.   (setvar "cmdecho" oldcmdecho)
    
76.   (setvar "attreq" attreq)
    
77.   (princ)
    
78.   )
    

;;;(tk 图块名) 2010.12.14 By Gu_xl<br /> (defun tk(tkname p1 p2 /  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 />   (command "insert" tkname pp1 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 -90<br />           )<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 90<br />           )<br />         )<br />         )<br />   (entdel en)<br />   (command "insert" tkname pp1 xscale yscale 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 (= :vlax-true (vla-get-HasAttributes obj))<br />     (command "eattedit" en)<br />     )<br /> (princ)<br />   )<br /> ;;;测试<br /> (defun c:tk()<br />   (setq oldcmdecho (getvar "cmdecho"))<br />   (setq attreq (getvar "attreq"))<br />   (setvar "cmdecho" 0)<br />   (setvar "attreq" 0)<br />   (setq blkname (getstring "\n输入要插入的图框名称："))<br />   (while (and (setq p1 (getpoint "\n插入图框角点："))<br />               (setq p2 (GETCORNER p1 "图框另一角点")<br />               )<br />          )<br />   (tk blkname p1 p2)<br />     )<br />   (setvar "cmdecho" oldcmdecho)<br />   (setvar "attreq" attreq)<br />   (princ)<br />   )<br />

yoyoho

感谢Gu_xl 版主的程序
它解决了我图框只能水平插块不能垂直插块的问题
谢谢你!

xjfa

为什么我用的时候，插入的图框总有角度，不是水平的啊

bianjia2006

你的问题现在解决了吗？没有解决的话我可能可以帮上你。

梦里水香

Gu_xl 发表于 2011-1-29 11:39

受用了。。感谢一下！
LISP看起来很厉害，可惜脑瓜子不开窍。。学不了~