修改 原【高飞鸟】] 【飞鸟集】画衣柜的LISP程序的画平面衣柜
【飞鸟集】画衣柜的LISP程序（更新至2014.11.27)原来的帖子地址：【飞鸟集】画衣柜的LISP程序（更新至2014.11.27)
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=86629&fromuid=7328064
(出处: 明经CAD社区)
改了一点点看上去好看点，能力有限。希望有大佬在改下。
我这也是YG的修改版，不过设置了出入了默认图层
(vl-load-com)
(prompt "命令是YG")
;;;画衣柜的LISP程序-----------------------------------------------------
;;;Copyright Highflybird------------------------------------------------
;;;2011.04.30 ----------------------------------------------------------
(defun c:YG(/ lst doc size pIn str pnt pts scr dlt dist1 dist2 Vec dist
lst1 lst2 lst3 cur1 cur2 Cur3 obj1 obj2 Obj3 Objs sLen ang1 ang2 ang par
)
;;;出错处理
(defun *error* (msg)
(setvar "cecolor""bylayer") ;_ 恢复颜色随层；
(setvar "clayer" mylayer) ;恢复原有图层
(princ "错误信息: ")
(princ msg) ;_ 打印错误信息
(princ)
)
(setvar "measurement" 0) ; 设置公制单位
(setvar "cmdecho" 0) ; 关闭命令响应
(setvar "hpassoc" 0) ;设置填充时不关联
(setq mylayer (getvar "clayer")) ;保存当前层
(setq oldcolor (getvar "cecolor")) ;保存原有颜色
(if (< (setq size (getvar "USERR5")) 100.) ;初始化衣柜深
(progn
(setvar "USERR5" 600.)
(setq size 600.)
)
)
;;获取布置一侧，或设置衣柜深
(setq str "\n点取布置的一侧[设置(Set)] <走向右侧>:") ;获取布置方向
(initget 8 "Set")
(setq pIn (getpoint str))
(while (= pIn "Set")
(setq size (getvar "USERR5"))
(initget 14)
(setq size (getdist (strcat "\n输入衣柜深<" (rtos size) ">:"))) ;如果需要设置衣柜深
(if (>= size 100)
(setvar "USERR5" size)
(setq size (getvar "USERR5"))
)
(initget 8 "Set")
(setq pIn (getpoint str))
)
;;获取靠墙边
(initget 9) ;防止空输入，点可在画面外
(setq pnt (getpoint "\n起点:"))
(setq pts (cons pnt nil))
(setq str "\n选取点<回车,空格或右键结束点取>:")
(while (setq pnt (getpoint (car pts) str)) ;通过点取方式获得靠墙边
(setq pnt (list (car pnt) (cadr pnt))) ;这步不可少，防止不在同个平面上
(grdraw pnt (car pts) 3 1) ;虚线显示布置靠墙边
(setq pts (cons pnt pts))
)
;;输入完成开始画图
(if (> (lengthpts) 1) ;至少要两点
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark doc) ;设置Undo起始点
(setq scr (GetRandFunction))
;;一些初始化工作--------------------------------------------------
(setq pts (reverse pts)) ;点集反转
;(setq pts (mapcar (function (lambda (x) (trans x 1 0))) pts)) ;把点集转化到世界坐标系
(if pIn
(setq pIn (trans pIn 1 0)
dlt (det (car pts) (cadr pts) pIn) ;右手法则
)
)
(if (> dlt 0) ;通过右手法则判断偏移方向
(setq dist1 (* size 0.5)
dist2 size
)
(setq dist1 (* size -0.5)
dist2 (- size)
)
)
;;首先构建衣柜的外轮廓和中心线------------------------------------
(setq lst1 (OffsetPts pts dist1 nil)) ;衣柜的中心线点
(setq lst2 (OffsetPts pts dist2 nil))
(setq lst2 (append pts (reverse lst2))) ;衣柜的外轮廓点
(setq Cur1 (make-Poly lst1 nil)) ;画衣柜的中心线
(setq Cur2 (make-Poly lst2 T)) ;画衣柜的中心线
(setq Obj1 (vlax-ename->vla-object Cur1))
(setq Obj2 (vlax-ename->vla-object Cur2))
(setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
(setq Cur3 (make-Poly lst3 T))
(setq obj3 (vlax-ename->vla-object Cur3))
(setq lst(list obj1 obj2 obj3))
(setq Objs (Make-clothes-hanger)) ;画衣架
(setq dist 0.0)
(setq sLen (vla-get-length Obj1)) ;中心线长度
(setq ang1 (/ pi 0.1 180)) ;摆动幅度在10度左右
(setq ang2 (- ang1))
(while (< dist sLen)
(setq pnt (vlax-curve-getPointAtDist Obj1 dist)) ;衣架的定位点
(setq par (vlax-curve-getParamAtDist Obj1 dist))
(setq Vec (vlax-curve-getFirstDeriv Obj1 par)) ;衣架的水平方向
(setq ang (angle '(0 0 0) Vec))
(setq ang (+ ang (Rand scr ang1 ang2))) ;衣架的旋转角度
(setq pIn (vlax-curve-getPointAtParam obj1 (fix (+ 0.5 par))));转点
(if (>= (distance pnt pIn) 300) ;如果与转点距离大于300
(Copy-and-tranformby Objs pnt ang) ;拷贝原点处衣架并变换
)
(setq dist (+ dist (Rand scr 80 300))) ;步进到下一点(100,300)这两个数值可自调
)
(mapcar 'vla-erase Objs) ;把原点处衣架删除
(makeGroup Doc Lst)
(and scr (vlax-release-object scr)) ;释放脚本实例
(vla-EndUndoMark doc) ;设置Undo终止点
(vlax-release-object doc)
)
)
(redraw) ;重画一下，消除Grdraw的痕迹
(command "color" oldcolor) ;设置为原有颜色
;; (setvar "cecolor" "bylayer");设置颜色随层
(setvar "clayer" mylayer)
(princ) ;静默退出
)
(defun sign (x)
(if (< x 0) -1 1)
)
;;;画线段
(defun Make-Line (p q)
(entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
)
;;;绘制多段线
(defun Make-Poly (pp isClosed / C)
;;;;;;;;;;;;设置画线层
(if (= (tblsearch "layer" "0-PM-固定家具") nil)
(Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
(Command "-layer" "t" "0-PM-固定家具" "")
)
(setvar "clayer" "0-PM-固定家具")
(if isClosed
(setq C 1)
(setq C 0)
)
(entmakeX ;画凸包
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length pp)) ;顶点个数
(cons 70 C) ;闭合的
)
(mapcar
(function
(lambda (x)
(cons 10 (reverse (cdr (reverse (trans x 1 0)))))
)
)
pp
) ;多段线顶点
)
)
)
;;;画衣架
(defun Make-clothes-hanger (/)
(mapcar
(function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
'((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
'((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
)
)
;;;拷贝原点处的物体并变换
(defun Copy-and-tranformby (Objs pnt Ang / newObj)
(foreach obj Objs
(setq NewObj (vla-copy obj))
(vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
(vla-rotate NewObj (vlax-3d-point pnt) Ang)
(setq lst (cons NewObj lst))
)
)
;;;最后做成组
(defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
(setq Groups (vla-get-groups doc))
(setq sGroup (getvar "cdate"))
(setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
(setq oGroup (vla-add Groups (strcat "YG" sGroup)))
(setq aBound (cons 0(1- (length objLst))))
(setq eArray (vlax-make-safearray vlax-vbObject aBound))
(vlax-safearray-fill eArray objLst)
(vla-AppendItems oGroup eArray)
)
;;;偏移点集(没用vla-offset)
;;;此函数可以扩展，为以后的编程准备
(defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
(setq ppp pts)
(setq cnt (length ppp))
(cond
( (>= cnt 2)
(setq hPi (/ Pi 2))
(setq pt1 (car ppp))
(setq pt2 (cadr ppp))
(setq an1 (angle pt1 pt2))
(setq pn1 (polar pt1 (+ an1 hPi) d))
(setq pn2 (polar pt2 (+ an1 hPi) d))
(setq pn4 pn2)
(setq lst (list pn1))
(if isClosed
(setq ppp (append pts (list (car pts)))
p12 (list pn1 pn2)
)
)
(while (caddr ppp)
(setq pt1 (car ppp))
(setq pt2 (cadr ppp))
(setq pt3 (caddr ppp))
(setq an1 (angle pt1 pt2))
(setq pn1 (polar pt1 (+ an1 hPi) d))
(setq pn2 (polar pt2 (+ an1 hPi) d))
(setq an2 (angle pt2 pt3))
(setq pn3 (polar pt2 (+ an2 hPi) d))
(setq pn4 (polar pt3 (+ an2 hPi) d))
(setq pnt (inters pn1 pn2 pn3 pn4 nil))
(andpnt (setq lst (cons pnt lst)))
(setq ppp (cdr ppp))
)
(if isClosed
(setq lst (cdr (reverse lst))
pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
lst (cons pnt lst)
)
(setq lst (cons pn4 lst)
lst (reverse lst)
)
)
(vl-remove nil lst)
)
)
)
;;;===============
;;;行列式,判别法则
;;;===============
(defun det (p1 p2 p3 / x1 y1)
(setq x1 (car p1)
y1 (cadr p1)
)
(- (* (- (car p2) x1) (- (cadr p3) y1))
(* (- (car p3) x1) (- (cadr p2) y1))
)
)
;;;---------------------------------------------------------------------
;;;Definine Rand()--which one is better? I don't know.
;;;---------------------------------------------------------------------
(defun GetRandFunction(/ scr str)
(setq scr (vlax-create-object "ScriptControl")) ;Create a script
(if scr
(progn
(vlax-put scr 'Language "VBS")
(setq str "Randomize\n
Function Rand(x,y)\n
Rand=x+Rnd*(y-x)\n
End Function"
) ;for randomize some features
(vlax-invoke Scr 'ExecuteStatement str) ;Execute script
(defun Rand (scr nMin nMax) ;Rand function
(vlax-invoke scr 'run "Rand" nMin nMax)
)
)
;;;rand function-some code from Le,--thanks.
(defun Rand (Option nMin nMax / seed)
(setq seed (getvar "USERR4"))
(if (= seed 0.)
(setq seed (getvar "TDUSRTIMER")
seed (- seed (fix seed))
seed (rem (* seed 86400) 1)
)
)
(setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
(setvar "USERR4" seed)
(+ nMin (* seed (- nMax nMin)))
)
)
scr
)
;;;;;;;;;;;柜子平面
;坛子里找个简单代码,类似达到效果
(defun c:SG ( / _line )
(defun *error* (msg)
(setvar "cecolor""bylayer") ;_ 恢复颜色随层；
(setvar "clayer" mylayer) ;恢复原有图层
(princ "错误信息: ")
(princ msg) ;_ 打印错误信息
(princ)
)
(setvar "measurement" 0) ; 设置公制单位
(setvar "cmdecho" 0) ; 关闭命令响应
(setvar "hpassoc" 0) ;设置填充时不关联
(setq mylayer (getvar "clayer")) ;保存当前层
(setq oldcolor (getvar "cecolor")) ;保存原有颜色
(defun _line (lst)
(if (= (tblsearch "layer" "0-PM-固定家具") nil)
(Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
(Command "-layer" "t" "0-PM-固定家具" "")
)
(setvar "clayer" "0-PM-固定家具")
(mapcar '(lambda (a b)(entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))) lst (cdr lst))
)
(while (and (setq n (Cond ((getint(strcat "\n等分数["(itoa(setq n(Cond ( n )( 5 ))))"] ")))( n )))
(setq p1 (getpoint "\n第一角点 :"))
(setq p2 (getcorner p1 "\n另一角点 :"))
)
(setq dx (abs (- (car p2) (car p1)))
dy (abs (- (cadr p2) (cadr p1)))
)
(setq ptm (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2)))
p2(list (max (car p1) (car p2)) (max (cadr p1) (cadr p2)))
p1ptm
)
(if (> dx dy)
(progn
(setq dd (/ dx n))
(repeat n
(setq p3 (polar p1 0 dd)
p4 (polar p1 (/ pi 2) dy)
p5 (polar p4 0 dd)
)
(_LINE (list p1 p3 p4 p5 p1 p4))
(setq p1 p3)
)
)
(progn
(setq dd (/ dy n))
(repeat n
(setq p3 (polar p1 (/ pi 2) dd)
p4 (polar p1 0 dx)
p5 (polar p3 0 dx)
)
(_LINE (list p1 p3 p4 p5 p1 p4))
(setq p1 p3)
)
)
)
(_LINE (list p3 p5))
)
(command "color" oldcolor) ;设置为原有颜色
;;(setvar "cecolor" "bylayer");设置颜色随层
;;(setvar "color" "251");设置颜色随层
(setvar "clayer" mylayer)
(princ)
)
感谢:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P:P 这个必须点赞了 这个必须点赞了--
这个必须点赞了 这个必须点赞了
这个必须点赞了 小毛草 发表于 2022-6-24 11:11
我这也是YG的修改版，不过设置了出入了默认图层
呵呵，厉害就是需要这个，衣柜没啥问题了，但是那个个柜子平面不这么好用 不能设置一侧的距离，随意2点画的，不是很好用，大佬能改下？改成图片的效果 小毛草 发表于 2022-6-24 11:11
我这也是YG的修改版，不过设置了出入了默认图层
最高柜子平面也能和衣柜一样设置一侧尺寸
页:
[1]
2