求动态拖动矩形的一个角点或一条边的LISP代码
请问，有没有动态拖动矩形的一个角点或一条边的LISP代码？我不会动态。我碰到的问题是，我画了一个矩形A，我要微调它的大小，一动，它就变成了非矩形。我希望我拖动它一条边或一个角点时，它永远为矩形，这样就美观。
我希望代码对与坐标轴斜交的矩形也有效。当然如果只是对与坐标轴平行的有效也可以。
这个很有用途的啊。矩形多好看，歪多边形多难看
本帖最后由 llsheng_73 于 2014-1-5 20:33 编辑
(defun dragrect(/ e e2 a b c d f g p p1 p2 q pt oldMACRO Plinexy ptoline makepl isrect)
(defun Plinexy(e / p a b n ob q et d d1 en et) ;;多线段节点坐标(滤掉了多余点，未处理假闭合)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q))))
)))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))))P)
(defun ptoline(p p1 p2 / l a b c d);;p在线外p1近端点p2远端点
(if(>(distance p p1)(distance p p2))(setq d p1 p1 p2 p2 d))
(setq a(distance p1 p2)
c(distance p p1)
b(distance p p2)
l(/(-(+(* a a)(* c c))(* b b))(* a 2))
d(polar p1(if(< l 0)(angle p2 p1)(angle p1 p2))(abs l))))
(defun makepl(pt)
(entmake(append(list'(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")
'(8 . "0")'(90 . 4)'(70 . 1))(mapcar'(lambda(x)(cons 10 x))pt))))
(defun isrect(e / pt)
(if(and(=(length(setq pt(plinexy e)))4)
(null(vl-remove 0.0(mapcar'cdr(vl-remove-if-not'(lambda (x)(=(car x)42))(entget e)))))
(EQUAL(distance(car pt)(nth 2 pt))(distance(nth 1 pt)(nth 3 pt))1e-6))pt))
(setq oldMACRO(getvar"MODEMACRO"))
(initget"1 2 3")
(setq c(getkword"\n固定方式1.自动,2固定点取边,3固定对边<3>"))
(if(null c)(setq c"3"))
(initget"1 2")(setq d(getkword"调整方式1.自由拖动,2输入面积<1>"))(if(null d)(setq d"1"))
(while(setq b(entsel"\n选择矩形(右键退出)"))
(if(setq e2 nil a(car b)b(nth 1 b) pt(isrect a))
(progn
(if(<"1"c)
(setq f(cdar(vl-sort(list(list(distance(ptoline b(car pt)(cadr pt))b)(car pt)(cadr pt))
(list(distance(ptoline b(cadr pt)(caddr pt))b)(cadr pt)(caddr pt))
(list(distance(ptoline b(caddr pt)(last pt))b)(caddr pt)(last pt))
(list(distance(ptoline b(car pt)(last pt))b)(car pt)(last pt)))
(function(lambda(x y)(<(car x)(car y))))))
g(vl-remove(last f)(vl-remove(car f)pt))
f(if(="3"c)(setq p g g f f p)f)))
(setvar"MODEMACRO"(strcat"面积="(rtos(vla-get-area(vlax-ename->vla-object a))2 4)))
(if(="1"d)
(progn
(while(/=(car(setq b(grread 5)))3)
(if e2(entdel(entlast)))
(if(="1"c)
(setq b(nth 1 b)
p(vl-sort pt(function(lambda(x y)(<(distance x b)(distance y b)))))
q(list(nth 1 p)(nth 2 p))p(last p)
p1(ptoline b p(car q))
p2(ptoline b p(cadr q)))
(setq b(nth 1 b)p1(car f)
ang(angle(ptoline b(last f)p1)b)
di(distance(ptoline b(last f)p1)b)
b(last f)
p(polar p1 ang di)
p2(polar b ang di)))
(setq e2(makepl(mapcar'(lambda(x)(list(car x)(cadr x)))(list b p1 p p2))))
(setvar"MODEMACRO"(strcat"面积="(rtos(*(distance b p1)(distance b p2))2 4))))
(if e2(entdel(entlast)))
(if(="1"c)
(setq b(nth 1 b)
p(vl-sort pt(function(lambda(x y)(<(distance x b)(distance y b)))))
q(list(nth 1 p)(nth 2 p))p(last p)
p1(ptoline b p(car q))
p2(ptoline b p(cadr q)))
(setq b(nth 1 b)p1(car f)
ang(angle(ptoline b(last f)p1)b)
di(distance(ptoline b(last f)p1)b)
b(last f)
p(polar p1 ang di)
p2(polar b ang di)))
(setvar"MODEMACRO"(strcat"面积="(rtos(*(distance b p1)(distance b p2))2 4))))
(progn
(setq e2(getreal"输入目标面积"))
(setq p1(car f)b(last f)
ang(if(equal(rem(abs(-(angle p1(car g))(angle p1 b)))pi)1.57079633 1e-6)(angle p1(car g))(angle p1(last g)))
di(/ e2(distance p1 b))
p(polar p1 ang di)
p2(polar b ang di))))
(setq e(entget a)e2(member(assoc 90 e)e))
(foreach x e2(setq e(vl-remove x e)))
(setq e(append e'((90 . 4)(70 . 1)))
e(if(assoc 43 e2)(append e(list(assoc 43 e2))))
e(if(assoc 38 e2)(append e(list(assoc 38 e2))))
e(if(assoc 39 e2)(append e(list(assoc 39 e2))))
e2(member(assoc 10 e2)e2))
(foreach x(mapcar'(lambda(x)(list(car x)(cadr x)))(list b p1 p p2))
(setq e(append e(list(cons 10 x)(cadr e2)(caddr e2)'(42 . 0)))e2(cddddr e2)))
(entmod e))(alert"你选择的不是矩形")))
(setvar"MODEMACRO"oldMACRO)
(princ))
试试这个
本帖最后由 陨落 于 2014-1-5 11:18 编辑
编程的话有个问题就是捕捉设置很麻烦，你可以看看这个http://bbs.mjtd.com/forum.php?mod=viewthread&tid=84963，可以解决你一部分问题 陨落 发表于 2014-1-5 11:17 static/image/common/back.gif
编程的话有个问题就是捕捉设置很麻烦，你可以看看这个http://bbs.mjtd.com/forum.php?mod=viewthread&tid=8 ...
谢谢，实在难。能帮我写一个吗？ 用高版吧，我用2014就有这功能，直接就可以拖动.
专业软件限制，只能最高用CAD2005 (defun C:tt (/ OS P1 P2 P LST)
(setq OS (getvar 'OSMODE))
(setvar 'OSMODE 0)
(vl-catch-all-apply
'(lambda ()
(while (and (setq P1 (getpoint "\n指定第一个角点: "))
(setq P2 (getcorner P1 "\n指定对角点: "))
)
(and (ssget "_C" P1 P2)
(setq LST (cons (list P1 P2) LST))
(grvecs (list -160
P1
(setq P (cons (car P1) (cdr P2)))
-160
P2
P
-160
P1
(setq P (cons (car P2) (cdr P1)))
-160
P2
P
)
)
)
)
(and LST
(setvar 'OSMODE OS)
(setq P1 (getpoint "\n指定基点: "))
(setq P2 (getpoint P1 "\n指定第二个点: "))
(setvar 'OSMODE 0)
(foreach X LST
(apply 'command
(append '("_.STRETCH" "_C") X (list "" P1 P2))
)
)
)
)
)
(redraw)
(setvar 'OSMODE OS)
(princ)
)
应该是像这样吧
看演示，你操作有误吧 本帖最后由 清风明月名字 于 2014-1-5 16:52 编辑
不行的，我也不知道什么原因。可能是你有意沿它的延伸方向拖动的，而我没有
页:
[1]
2