诚求画矩形的小程序！

泉(Ango)

各位，
        大家好。在下有礼啦。我现要画很多不同宽度和长度的矩形条，所以我想就是输入一个快捷键（如：FX），然后CAD提示我输入矩形条的宽度，在输入宽度后，我任意点选平面上的两点，就能画出一条矩形条，该矩形条的宽度等于我输入的宽度值，长度等于我点选的两点间的距离，但这个矩形条的宽的中心必须分别在我点选的两点上（也就是说，该矩形的宽度关于我点选的两点所成的直线对称）。
        这与平常画的条形不一样。第一，平常画的矩形所点选的两点为矩形的对角点，而我现要的是我点选平面上的两点为宽度（参数）的中心点；第二，平常画的矩形是一个水平放置的矩形，而我现要的是矩形条不一定是水平放置，而是矩形条非宽度的边可能是水平，也可能是垂直，也可能是斜的，该边的斜率等于我点选平面上的两点所成直线的斜率。
        请问用LISP程序怎样编这样的程序。恳请赐教。

qjg_77

正是我需要的，学习下

894560869

仰慕啊辛苦了

Krio飞

很好 拜学了

yjr111

2. ;;;;;;;;;;;;非正交矩形画法3种
   
3. (defun c:juxing1(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)
   
4.   (princ"\n.........动态任意矩形(命令juxing1)........")
   
5.   (vla-startUndoMark mydoc)
   
6.   (if(setq pt1(getpoint"\n请输入矩形边第一点："))
   
7.     (if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))
   
8.       (progn
   
9.         (entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))
   
10.         (setq ent(entlast)flag t)
    
11.         (princ"\n请拖动鼠标决定矩形大小，任意键确定...")
    
12.         (while(and flag(setq gr(grread t 8) grn(car gr) grp(cadr gr)))
    
13.           (cond((= grn 5)
    
14.                 (if ent2 (vla-delete (vlax-ename->vla-object ent2)))
    
15.                 (setq dist (distance (setq pt3(apply 'vlax-curve-getclosestpointto (list ent grp)))grp))
    
16.                 (setq entobj(vla-copy (vlax-ename->vla-object ent)))
    
17.                 (vla-move entobj (vlax-3d-point pt3)(vlax-3d-point grp))
    
18.                 (setq pt4(vlax-curve-getstartpoint entobj)
    
19.                       pt5(vlax-curve-getendpoint entobj)
    
20.                       )
    
21.                 (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))
    
22.                                (mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))
    
23.                          )
    
24.                 (setq ent2(entlast))
    
25.                 (vla-delete entobj)
    
26.                 )
    
27.                (t
    
28.                 (setq flag nil)
    
29.                 (vla-delete (vlax-ename->vla-object ent))
    
30.                 )
    
31.                )
    
32.           )
    
33.         )
    
34.       )
    
35.     )
    
36.   (vla-endUndoMark mydoc)
    
37.   (princ)
    
38.   )
    
39. 
    
40. (defun c:juxing2(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)
    
41.   (princ"\n.........三点任意矩形(命令juxing2)........")
    
42.   (vla-startUndoMark mydoc)
    
43.   (if(setq pt1(getpoint"\n请输入矩形边第一点："))
    
44.     (if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))
    
45.       (progn
    
46.         (entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))
    
47.         (setq ent(entlast))
    
48.         (if (setq pt3(getpoint pt2"\n请输入一点确定矩形方向："))      
    
49.         (progn
    
50.         (setq dist (distance (setq pt6(apply 'vlax-curve-getclosestpointto (list ent pt3)))pt3))
    
51.         (setq entobj(vla-copy (vlax-ename->vla-object ent)))
    
52.         (vla-move entobj (vlax-3d-point pt6)(vlax-3d-point pt3))
    
53.         (setq pt4(vlax-curve-getstartpoint entobj)
    
54.               pt5(vlax-curve-getendpoint entobj)
    
55.               )
    
56.         (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))
    
57.                        (mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))
    
58.                  )
    
59.         (setq ent2(entlast))
    
60.         (vla-delete entobj)
    
61.         (vla-delete (vlax-ename->vla-object ent))
    
62.         )
    
63.        )
    
64.       )
    
65.     )
    
66.    )
    
67.   (vla-endUndoMark mydoc)
    
68.   (princ)
    
69. )
    
70. (defun c:juxing3()
    
71.   (princ"\n.........旋转矩形(命令juxing3)........")
    
72.   (setvar 'cmdecho 0)
    
73.   (setvar 'orthomode 0)
    
74.   (if(setq pt1(getpoint"\n请输入矩形第一点："))
    
75.     (vl-cmdf "rectang" pt1 "r" pause )
    
76.     )
    
77.   (princ)
    
78.   )

;;;;;;;;;;;;非正交矩形画法3种<br /> (defun c:juxing1(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)<br />   (princ"\n.........动态任意矩形(命令juxing1)........")<br />   (vla-startUndoMark mydoc)<br />   (if(setq pt1(getpoint"\n请输入矩形边第一点："))<br />     (if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))<br />       (progn<br />         (entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))<br />         (setq ent(entlast)flag t)<br />         (princ"\n请拖动鼠标决定矩形大小，任意键确定...")<br />         (while(and flag(setq gr(grread t 8) grn(car gr) grp(cadr gr)))<br />           (cond((= grn 5)<br />                 (if ent2 (vla-delete (vlax-ename->vla-object ent2)))<br />                 (setq dist (distance (setq pt3(apply 'vlax-curve-getclosestpointto (list ent grp)))grp))<br />                 (setq entobj(vla-copy (vlax-ename->vla-object ent)))<br />                 (vla-move entobj (vlax-3d-point pt3)(vlax-3d-point grp))<br />                 (setq pt4(vlax-curve-getstartpoint entobj)<br />                       pt5(vlax-curve-getendpoint entobj)<br />                       )<br />                 (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))<br />                                (mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))<br />                          )<br />                 (setq ent2(entlast))<br />                 (vla-delete entobj)<br />                 )<br />                (t<br />                 (setq flag nil)<br />                 (vla-delete (vlax-ename->vla-object ent))<br />                 )<br />                )<br />           )<br />         )<br />       )<br />     )<br />   (vla-endUndoMark mydoc)<br />   (princ)<br />   )<br /> <br /> (defun c:juxing2(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)<br />   (princ"\n.........三点任意矩形(命令juxing2)........")<br />   (vla-startUndoMark mydoc)<br />   (if(setq pt1(getpoint"\n请输入矩形边第一点："))<br />     (if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))<br />       (progn<br />         (entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))<br />         (setq ent(entlast))<br />         (if (setq pt3(getpoint pt2"\n请输入一点确定矩形方向："))      <br />         (progn<br />         (setq dist (distance (setq pt6(apply 'vlax-curve-getclosestpointto (list ent pt3)))pt3))<br />         (setq entobj(vla-copy (vlax-ename->vla-object ent)))<br />         (vla-move entobj (vlax-3d-point pt6)(vlax-3d-point pt3))<br />         (setq pt4(vlax-curve-getstartpoint entobj)<br />               pt5(vlax-curve-getendpoint entobj)<br />               )<br />         (entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))<br />                        (mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))<br />                  )<br />         (setq ent2(entlast))<br />         (vla-delete entobj)<br />         (vla-delete (vlax-ename->vla-object ent))<br />         )<br />        )<br />       )<br />     )<br />    )<br />   (vla-endUndoMark mydoc)<br />   (princ)<br /> )<br /> (defun c:juxing3()<br />   (princ"\n.........旋转矩形(命令juxing3)........")<br />   (setvar 'cmdecho 0)<br />   (setvar 'orthomode 0)<br />   (if(setq pt1(getpoint"\n请输入矩形第一点："))<br />     (vl-cmdf "rectang" pt1 "r" pause )<br />     )<br />   (princ)<br />   )

Gu_xl

1. (defun c:tt (/ w p1 p2 ang )
   
2.   (initget 7)
   
3.   (setq w (getdist "\n**输入宽度:"))
   
4.   
   
5.   (princ "\n**输入")
   
6.   (while (and
   
7.            (setq p1 (getpoint "第一点："))
   
8.            (setq p2  (getpoint p1 "\n**第二点："))
   
9.            )
   
10.     (setq ang (angle p1 p2) l (distance p1 p2))
    
11.     (entmake
    
12.       (list
    
13.         '(0 . "LWPOLYLINE")
    
14.         '(100 . "AcDbEntity")
    
15.         '(100 . "AcDbPolyline")
    
16.         '(90 . 4)
    
17.         '(70 . 1)
    
18.         '(43 . 0.0)
    
19.         '(38 . 0.0)
    
20.         '(39 . 0.0)
    
21.         (cons 10 (trans (setq p(polar p1 (+ ang (* 0.5 pi)) (* 0.5 w))) 1 0))
    
22.         (cons 10 (trans (setq p (polar p ang l)) 1 0))
    
23.         (cons 10 (trans (setq p (polar p (- ang (* 0.5 pi)) w)) 1 0))
    
24.         (cons 10 (trans (setq p (polar p (+ pi ang) l)) 1 0))
    
25.         )
    
26.       )
    
27.     (princ "\n**继续输入")
    
28.     )
    
29.   (princ)
    
30.   )

(defun c:tt (/ w p1 p2 ang )<br />   (initget 7)<br />   (setq w (getdist "\n**输入宽度:"))<br />   <br />   (princ "\n**输入")<br />   (while (and<br />            (setq p1 (getpoint "第一点："))<br />            (setq p2  (getpoint p1 "\n**第二点："))<br />            )<br />     (setq ang (angle p1 p2) l (distance p1 p2))<br />     (entmake<br />       (list<br />         '(0 . "LWPOLYLINE")<br />         '(100 . "AcDbEntity")<br />         '(100 . "AcDbPolyline")<br />         '(90 . 4) <br />         '(70 . 1)<br />         '(43 . 0.0)<br />         '(38 . 0.0)<br />         '(39 . 0.0)<br />         (cons 10 (trans (setq p(polar p1 (+ ang (* 0.5 pi)) (* 0.5 w))) 1 0))<br />         (cons 10 (trans (setq p (polar p ang l)) 1 0))<br />         (cons 10 (trans (setq p (polar p (- ang (* 0.5 pi)) w)) 1 0))<br />         (cons 10 (trans (setq p (polar p (+ pi ang) l)) 1 0))<br />         )<br />       )<br />     (princ "\n**继续输入")<br />     )<br />   (princ)<br />   )

yuanziyou

Gu_xl 发表于 2013-1-9 13:07

又快又准!

haoryh

两大高人出手，兄弟：你有福了！

革天明

haoryh 发表于 2013-1-9 14:40
两大高人出手，兄弟：你有福了！

真有福气啊

xsso

yjr111 发表于 2013-1-9 12:59

(vla-startUndoMark mydoc)
这个让前两个不能用

848818376

gu版最好，绝对的支持

泉(Ango)

非常感激yjr111 和Gu_xl 的顶力帮助，同时也感激顶帖的各位。小弟学习了.thanks.

AbnerXk

楼主有福