社区 › 编程申请 › 把"框选自动调出图框的程序"完善一下

bai2000 发表于 2010-12-26 22:44:56

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

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

vodoo 发表于 2010-12-29 21:40:49

我用的是VBA

xiaxiang 发表于 2011-1-6 17:56:00

用这个试试

ljttjl 发表于 2011-1-26 21:17:12

bai2000 发表于 2011-1-26 22:43:01

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

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

本帖最后由 Gu_xl 于 2011-1-29 11:40 编辑


;;;(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)
)

yoyoho 发表于 2011-2-13 17:02:58

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

xjfa 发表于 2011-2-14 11:07:37

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

bianjia2006 发表于 2011-3-15 20:12:17

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

梦里水香 发表于 2012-12-8 16:27:30

Gu_xl 发表于 2011-1-29 11:39 static/image/common/back.gif


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

查看完整版本: 把"框选自动调出图框的程序"完善一下