求动态拖动矩形的一个角点或一条边的LISP代码

清风明月名字 · 发表于 2014-1-5 10:25:12

请问，有没有动态拖动矩形的一个角点或一条边的LISP代码？我不会动态。
我碰到的问题是，我画了一个矩形A，我要微调它的大小，一动，它就变成了非矩形。我希望我拖动它一条边或一个角点时，它永远为矩形，这样就美观。
我希望代码对与坐标轴斜交的矩形也有效。当然如果只是对与坐标轴平行的有效也可以。
这个很有用途的啊。矩形多好看，歪多边形多难看

llsheng_73 · 发表于 2014-1-5 10:25:13

本帖最后由 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))

(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:17:31

本帖最后由陨落于 2014-1-5 11:18 编辑

编程的话有个问题就是捕捉设置很麻烦，你可以看看这个http://bbs.mjtd.com/forum.php?mod=viewthread&tid=84963，可以解决你一部分问题

清风明月名字 · 发表于 2014-1-5 11:25:57

陨落发表于 2014-1-5 11:17
编程的话有个问题就是捕捉设置很麻烦，你可以看看这个http://bbs.mjtd.com/forum.php?mod=viewthread&tid=8 ...

谢谢，实在难。能帮我写一个吗？

kwok · 发表于 2014-1-5 15:28:09

用高版吧，我用2014就有这功能，直接就可以拖动.

清风明月名字 · 发表于 2014-1-5 15:37:35

专业软件限制，只能最高用CAD2005

flyfox1047 · 发表于 2014-1-5 16:06:40

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

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

flyfox1047 · 发表于 2014-1-5 16:10:30

应该是像这样吧

flyfox1047 · 发表于 2014-1-5 16:32:04

看演示，你操作有误吧

清风明月名字 · 发表于 2014-1-5 16:33:55

本帖最后由清风明月名字于 2014-1-5 16:52 编辑

不行的，我也不知道什么原因。可能是你有意沿它的延伸方向拖动的，而我没有

账号		自动登录	找回密码
密码			注册

[讨论] 求动态拖动矩形的一个角点或一条边的LISP代码

最佳答案

相关帖子

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

本帖子中包含更多资源

点评