求框选自动调出图框的程序？

ljttjl

lonshinyoo

ljttjl 发表于 2011-1-25 21:08

楼上兄弟能否共享啊！

bai2000

院长的程序怎么用不了？？？请院长看看

Gu_xl

回复 cj52000 的帖子

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 />

terry_uhc

真强!!顶一下!

461045462

上传一个调1:500 地形图廓的正式图框lsp与大家学习，不足之处请指教。
谢谢。

弓志贤

谢谢“ljttjl”的分享

vitoliming

学习了，很不错

haiyunzhou

非常感谢  学习了

springwillow

G版就是厉害！