诚求画矩形的小程序！
各位，大家好。在下有礼啦。我现要画很多不同宽度和长度的矩形条，所以我想就是输入一个快捷键（如：FX），然后CAD提示我输入矩形条的宽度，在输入宽度后，我任意点选平面上的两点，就能画出一条矩形条，该矩形条的宽度等于我输入的宽度值，长度等于我点选的两点间的距离，但这个矩形条的宽的中心必须分别在我点选的两点上（也就是说，该矩形的宽度关于我点选的两点所成的直线对称）。
这与平常画的条形不一样。第一，平常画的矩形所点选的两点为矩形的对角点，而我现要的是我点选平面上的两点为宽度（参数）的中心点；第二，平常画的矩形是一个水平放置的矩形，而我现要的是矩形条不一定是水平放置，而是矩形条非宽度的边可能是水平，也可能是垂直，也可能是斜的，该边的斜率等于我点选平面上的两点所成直线的斜率。
请问用LISP程序怎样编这样的程序。恳请赐教。 正是我需要的，学习下 仰慕啊辛苦了 很好 拜学了 ;;;;;;;;;;;;非正交矩形画法3种
(defun c:juxing1(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)
(princ"\n.........动态任意矩形(命令juxing1)........")
(vla-startUndoMark mydoc)
(if(setq pt1(getpoint"\n请输入矩形边第一点："))
(if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))
(progn
(entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))
(setq ent(entlast)flag t)
(princ"\n请拖动鼠标决定矩形大小，任意键确定...")
(while(and flag(setq gr(grread t 8) grn(car gr) grp(cadr gr)))
(cond((= grn 5)
(if ent2 (vla-delete (vlax-ename->vla-object ent2)))
(setq dist (distance (setq pt3(apply 'vlax-curve-getclosestpointto (list ent grp)))grp))
(setq entobj(vla-copy (vlax-ename->vla-object ent)))
(vla-move entobj (vlax-3d-point pt3)(vlax-3d-point grp))
(setq pt4(vlax-curve-getstartpoint entobj)
pt5(vlax-curve-getendpoint entobj)
)
(entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))
(mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))
)
(setq ent2(entlast))
(vla-delete entobj)
)
(t
(setq flag nil)
(vla-delete (vlax-ename->vla-object ent))
)
)
)
)
)
)
(vla-endUndoMark mydoc)
(princ)
)
(defun c:juxing2(/ pt1 pt2 ent gr grn grp ent2 dist entobj pt4 pt5)
(princ"\n.........三点任意矩形(命令juxing2)........")
(vla-startUndoMark mydoc)
(if(setq pt1(getpoint"\n请输入矩形边第一点："))
(if(setq pt2(getpoint pt1"\n请输入矩形边另一点："))
(progn
(entmake (list '(0 . "LINE")(cons 10 pt1)(cons 11 pt2)))
(setq ent(entlast))
(if (setq pt3(getpoint pt2"\n请输入一点确定矩形方向："))
(progn
(setq dist (distance (setq pt6(apply 'vlax-curve-getclosestpointto (list ent pt3)))pt3))
(setq entobj(vla-copy (vlax-ename->vla-object ent)))
(vla-move entobj (vlax-3d-point pt6)(vlax-3d-point pt3))
(setq pt4(vlax-curve-getstartpoint entobj)
pt5(vlax-curve-getendpoint entobj)
)
(entmake (append(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 5))
(mapcar '(lambda(x)(cons 10 x))(list pt1 pt2 pt5 pt4 pt1)))
)
(setq ent2(entlast))
(vla-delete entobj)
(vla-delete (vlax-ename->vla-object ent))
)
)
)
)
)
(vla-endUndoMark mydoc)
(princ)
)
(defun c:juxing3()
(princ"\n.........旋转矩形(命令juxing3)........")
(setvar 'cmdecho 0)
(setvar 'orthomode 0)
(if(setq pt1(getpoint"\n请输入矩形第一点："))
(vl-cmdf "rectang" pt1 "r" pause )
)
(princ)
)
(defun c:tt (/ w p1 p2 ang )
(initget 7)
(setq w (getdist "\n**输入宽度:"))
(princ "\n**输入")
(while (and
(setq p1 (getpoint "第一点："))
(setq p2(getpoint p1 "\n**第二点："))
)
(setq ang (angle p1 p2) l (distance p1 p2))
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 (trans (setq p(polar p1 (+ ang (* 0.5 pi)) (* 0.5 w))) 1 0))
(cons 10 (trans (setq p (polar p ang l)) 1 0))
(cons 10 (trans (setq p (polar p (- ang (* 0.5 pi)) w)) 1 0))
(cons 10 (trans (setq p (polar p (+ pi ang) l)) 1 0))
)
)
(princ "\n**继续输入")
)
(princ)
) Gu_xl 发表于 2013-1-9 13:07 static/image/common/back.gif
又快又准! 两大高人出手，兄弟：你有福了！ haoryh 发表于 2013-1-9 14:40 static/image/common/back.gif
两大高人出手，兄弟：你有福了！
真有福气啊 yjr111 发表于 2013-1-9 12:59 static/image/common/back.gif
(vla-startUndoMark mydoc)
这个让前两个不能用 gu版最好，绝对的支持 非常感激yjr111 和Gu_xl 的顶力帮助，同时也感激顶帖的各位。小弟学习了.thanks. 楼主有福