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

lonshinyoo 发表于 2011-1-25 22:38:38

ljttjl 发表于 2011-1-25 21:08 static/image/common/back.gif


楼上兄弟能否共享啊！

bai2000 发表于 2011-1-25 23:47:57

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

Gu_xl 发表于 2011-1-28 18:44:33

本帖最后由 Gu_xl 于 2011-1-28 18:54 编辑

回复 cj52000 的帖子


;;;(tk 图块名) 2010.12.14 By Gu_xl
(defun tk(tkname p1 p2 /pp1 pp2 v h v1 h1 xscale yscale)

(setq pp1 (mapcar '(lambda (x)(apply 'min x))(apply 'mapcar (cons 'list (list p1 p2))))
      pp2 (mapcar '(lambda (x)(apply 'max x))(apply 'mapcar (cons 'list (list p1 p2))))
      v (- (cadr pp2) (cadr pp1))
      h (- (car pp2) (car pp1))
      )
(if (> h v)
      (setq v (/ h (/ 420. 297.)))
      (setq h (/ v(/ 420. 297.)))
      )
(command "insert" tkname pp1 1 1 0)
(setq en (entlast))
(vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)
(setq pl (mapcar 'vlax-safearray->list (list p1 p2)))
(setq p1 (vlax-safearray->list p1)
      p2 (vlax-safearray->list p2)
      v1 (- (cadr p2) (cadr p1))
      h1 (- (car p2) (car p1))
      )
(cond ((and (> h v) (>= h1 v1))
          (setq      xscale (/ h h1)
                yscale (/ v v1)
                rot 0
          )
      )
      ((and (> h v) (>= v1 h1))
          (setq      yscale (/ h v1)
                xscale (/ v h1)
                rot -90
          )
      )
      ((and (> v h) (>= v1 h1))
          (setq      xscale (/ v v1)
                yscale (/ h h1)
                rot 0
          )
      )
      ((and (> v h) (>= h1 v1))
          (setq      yscale (/ v h1)
                xscale (/ h v1)
                rot 90
          )
      )
      )
(entdel en)
(command "insert" tkname pp1 xscale yscale rot)
(setq en (entlast))
    (vla-getboundingbox (vlax-ename->vla-object en) 'p1 'p2)
(setq pl (mapcar 'vlax-safearray->list (list p1 p2)))
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
)
(command "move" en "" p1 pp1)
(setq obj (vlax-ename->vla-object en))
(if (= :vlax-true (vla-get-HasAttributes obj))
    (command "eattedit" en)
    )
(princ)
)
;;;测试
(defun c:tk()
(setq oldcmdecho (getvar "cmdecho"))
(setq attreq (getvar "attreq"))
(setvar "cmdecho" 0)
(setvar "attreq" 0)
(setq blkname (getstring "\n输入要插入的图框名称："))
(while (and (setq p1 (getpoint "\n插入图框角点："))
            (setq p2 (GETCORNER p1 "图框另一角点")
            )
         )
(tk blkname p1 p2)
    )
(setvar "cmdecho" oldcmdecho)
(setvar "attreq" attreq)
(princ)
)

terry_uhc 发表于 2011-1-29 10:08:24

真强!!顶一下!

461045462 发表于 2011-2-13 15:18:32

本帖最后由 461045462 于 2011-2-13 15:21 编辑

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

弓志贤 发表于 2011-12-10 22:30:28

谢谢“ljttjl”的分享

vitoliming 发表于 2011-12-12 20:52:04

学习了，很不错

haiyunzhou 发表于 2012-2-14 23:38:33

非常感谢学习了

springwillow 发表于 2012-2-17 12:43:29

G版就是厉害！
页: 1 2 [3] 4 5 6 7
查看完整版本: 求框选自动调出图框的程序？