画衣柜的程序

Posted on by

在CAD中画衣柜有时候是一件比较麻烦的事情，对2012以上的版本，可以用动态图块来实现，但还是有点罗嗦。
我下面的程序实现比较简单，只要敲入一个命令，然后你就可以任意布置你的衣柜了。
下面是其实现的代码。

  1. (vl-load-com)
  2. (prompt "命令是YG")
  3. ;;;画衣柜的LISP程序-----------------------------------------------------
  4. ;;;Copyright Highflybird------------------------------------------------
  5. ;;;2011.04.30 ----------------------------------------------------------
  6. (defun c:YG(/ lst doc size pIn str pnt pts scr dlt dist1 dist2 Vec dist 
  7.               lst1 lst2 lst3 cur1 cur2 Cur3 obj1 obj2 Obj3 Objs sLen ang1 ang2 ang par
  8.            )
  9.   (if (< (setq size (getvar "USERR5")) 100.)                            ;初始化衣柜深
  10.     (progn 
  11.       (setvar "USERR5" 600.)                                            
  12.       (setq size 600.)
  13.     )
  14.   )
  15.  
  16.   ;;获取布置一侧，或设置衣柜深
  17.   (setq str "n点取布置的一侧[设置(Set)] <走向右侧>:")                  ;获取布置方向
  18.   (initget 8 "Set")
  19.   (setq pIn (getpoint str))
  20.   (while (= pIn "Set")
  21.     (setq size (getvar "USERR5"))
  22.     (initget 14)
  23.     (setq size (getdist (strcat "n输入衣柜深<" (rtos size) ">:")))     ;如果需要设置衣柜深
  24.     (if (>= size 100)
  25.       (setvar "USERR5" size)
  26.       (setq size (getvar "USERR5"))
  27.     )
  28.     (initget 8 "Set")
  29.     (setq pIn (getpoint str))
  30.   )
  31.  
  32.   ;;获取靠墙边
  33.   (initget 9)                                                           ;防止空输入，点可在画面外
  34.   (setq pnt (getpoint "n起点:"))
  35.   (setq pts (cons pnt nil))
  36.   (setq str "n选取点<回车,空格或右键结束点取>:")
  37.   (while (setq pnt (getpoint (car pts) str))                            ;通过点取方式获得靠墙边
  38.     (setq pnt (list (car pnt) (cadr pnt)))                              ;这步不可少，防止不在同个平面上
  39.     (grdraw pnt (car pts) 3 1)                                          ;虚线显示布置靠墙边
  40.     (setq pts (cons pnt pts))                                   
  41.   )
  42.  
  43.   ;;输入完成开始画图
  44.   (if (> (length  pts) 1)                                               ;至少要两点
  45.     (progn
  46.       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  47.       (vla-StartUndoMark doc)                                           ;设置Undo起始点
  48.       (setq scr (GetRandFunction))
  49.       ;;一些初始化工作--------------------------------------------------
  50.       (setq pts (reverse pts))                                          ;点集反转
  51.       (setq pts (mapcar (function (lambda (x) (trans x 1 0))) pts))     ;把点集转化到世界坐标系
  52.       (if pIn
  53.         (setq pIn (trans pIn 1 0)
  54.               dlt (det (car pts) (cadr pts) pIn)                        ;右手法则
  55.         )
  56.       )                                                 
  57.       (if (> dlt 0)                                                     ;通过右手法则判断偏移方向
  58.         (setq dist1 (* size 0.5)
  59.               dist2 size
  60.         )
  61.         (setq dist1 (* size -0.5)
  62.               dist2 (- size)
  63.         )
  64.       )
  65.  
  66.       ;;首先构建衣柜的外轮廓和中心线------------------------------------
  67.       (setq lst1 (OffsetPts pts dist1 nil))                             ;衣柜的中心线点
  68.       (setq lst2 (OffsetPts pts dist2 nil))
  69.       (setq lst2 (append pts (reverse lst2)))                           ;衣柜的外轮廓点
  70.  
  71.       (setq Cur1 (make-Poly lst1 nil))                                  ;画衣柜的中心线
  72.       (setq Cur2 (make-Poly lst2 T))                                    ;画衣柜的中心线
  73.       (setq Obj1 (vlax-ename->vla-object Cur1))
  74.       (setq Obj2 (vlax-ename->vla-object Cur2))
  75.  
  76.       (setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
  77.       (setq Cur3 (make-Poly lst3 T))
  78.       (setq obj3 (vlax-ename->vla-object Cur3))
  79.  
  80.       (setq lst  (list obj1 obj2 obj3))
  81.  
  82.       (setq Objs (Make-clothes-hanger))                                 ;画衣架
  83.       (setq dist 0.0)
  84.       (setq sLen (vla-get-length Obj1))                                 ;中心线长度
  85.       (setq ang1 (/ pi 0.1 180))                                        ;摆动幅度在10度左右
  86.       (setq ang2 (- ang1))
  87.       (while (< dist sLen)
  88.         (setq pnt (vlax-curve-getPointAtDist Obj1 dist))                ;衣架的定位点
  89.         (setq par (vlax-curve-getParamAtDist Obj1 dist))
  90.         (setq Vec (vlax-curve-getFirstDeriv Obj1 par))                  ;衣架的水平方向
  91.         (setq ang (angle '(0 0 0) Vec))
  92.         (setq ang (+ ang (Rand scr ang1 ang2)))                         ;衣架的旋转角度
  93.         (setq pIn (vlax-curve-getPointAtParam obj1 (fix (+ 0.5 par))))  ;转点
  94.         (if (>= (distance pnt pIn) 300)                                 ;如果与转点距离大于300
  95.           (Copy-and-tranformby Objs pnt ang)                            ;拷贝原点处衣架并变换
  96.         )        
  97.         (setq dist (+ dist (Rand scr 80 300)))                          ;步进到下一点(100,300)这两个数值可自调
  98.       )
  99.       (mapcar 'vla-erase Objs)                                          ;把原点处衣架删除
  100.       (makeGroup Doc Lst)
  101.       (vlax-release-object scr)                                         ;释放脚本实例
  102.       (vla-EndUndoMark doc)                                             ;设置Undo终止点
  103.       (vlax-release-object doc)
  104.     )
  105.   )
  106.   (redraw)                                                              ;重画一下，消除Grdraw的痕迹
  107.   (princ)                                                               ;静默退出
  108. )
  109. (defun sign (x)
  110.   (if (< x 0) -1 1)
  111. )
  112. ;;;出错处理
  113. (defun *error_msg* (msg)
  114.   (redraw)
  115.   (princ msg)
  116. )
  117.  
  118. ;;;画线段
  119. (defun Make-Line (p q)
  120.   (entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
  121. )
  122.  
  123. ;;;绘制多段线
  124. (defun Make-Poly (pp isClosed / C)
  125.   (if isClosed
  126.     (setq C 1)
  127.     (setq C 0)
  128.   )
  129.   (entmakeX                                                             ;画凸包
  130.     (append
  131.       (list
  132.         (cons 0 "LWPOLYLINE")
  133.         (cons 100 "AcDbEntity")
  134.         (cons 100 "AcDbPolyline")
  135.         (cons 90 (length pp))                                           ;顶点个数
  136.         (cons 70 C)                                                     ;闭合的
  137.       )
  138.       (mapcar (function (lambda (x) (cons 10 x))) pp)                   ;多段线顶点
  139.     )
  140.   )
  141. )
  142.  
  143. ;;;画衣架
  144. (defun Make-clothes-hanger (/)
  145.   (mapcar
  146.     (function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
  147.     '((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
  148.     '((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
  149.   )
  150. )
  151.  
  152. ;;;拷贝原点处的物体并变换
  153. (defun Copy-and-tranformby (Objs pnt Ang / newObj)
  154.   (foreach obj Objs
  155.     (setq NewObj (vla-copy obj))
  156.     (vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
  157.     (vla-rotate NewObj (vlax-3d-point pnt) Ang)
  158.     (setq lst (cons NewObj lst))
  159.   )
  160. )
  161.  
  162. ;;;最后做成组
  163. (defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
  164.   (setq Groups (vla-get-groups doc))
  165.   (setq sGroup (getvar "cdate"))
  166.   (setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
  167.   (setq oGroup (vla-add Groups (strcat "YG" sGroup)))
  168.   (setq aBound (cons 0  (1- (length objLst))))
  169.   (setq eArray (vlax-make-safearray vlax-vbObject aBound))
  170.   (vlax-safearray-fill eArray objLst)
  171.   (vla-AppendItems oGroup eArray)
  172. )
  173.  
  174. ;;;偏移点集(没用vla-offset)
  175. ;;;此函数可以扩展，为以后的编程准备
  176. (defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
  177.   (setq ppp pts)
  178.   (setq cnt (length ppp))
  179.   (cond
  180.     ( (>= cnt 2)
  181.       (setq hPi (/ Pi 2))
  182.  
  183.       (setq pt1 (car ppp))
  184.       (setq pt2 (cadr ppp))
  185.  
  186.       (setq an1 (angle pt1 pt2))
  187.       (setq pn1 (polar pt1 (+ an1 hPi) d))
  188.       (setq pn2 (polar pt2 (+ an1 hPi) d))
  189.  
  190.       (setq pn4 pn2)
  191.  
  192.       (setq lst (list pn1))
  193.       (if isClosed
  194.         (setq ppp (append pts (list (car pts)))
  195.               p12 (list pn1 pn2)
  196.         )
  197.       )
  198.       (while (caddr ppp)
  199.         (setq pt1 (car ppp))
  200.         (setq pt2 (cadr ppp))
  201.         (setq pt3 (caddr ppp))
  202.  
  203.         (setq an1 (angle pt1 pt2))
  204.         (setq pn1 (polar pt1 (+ an1 hPi) d))
  205.         (setq pn2 (polar pt2 (+ an1 hPi) d))
  206.  
  207.         (setq an2 (angle pt2 pt3))
  208.         (setq pn3 (polar pt2 (+ an2 hPi) d))
  209.         (setq pn4 (polar pt3 (+ an2 hPi) d))
  210.  
  211.         (setq pnt (inters pn1 pn2 pn3 pn4 nil))
  212.         (and  pnt (setq lst (cons pnt lst)))
  213.         (setq ppp (cdr ppp))
  214.       )
  215.       (if isClosed
  216.         (setq lst (cdr (reverse lst))
  217.               pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
  218.               lst (cons pnt lst)
  219.         )
  220.         (setq lst (cons pn4 lst)
  221.               lst (reverse lst)
  222.         )
  223.       )
  224.       (vl-remove nil lst)
  225.     )  
  226.   )
  227. )
  228. ;;;===============
  229. ;;;行列式,判别法则
  230. ;;;===============
  231. (defun det (p1 p2 p3 / x1 y1)
  232.   (setq x1 (car p1)
  233.         y1 (cadr p1)
  234.   )
  235.   (- (* (- (car p2) x1) (- (cadr p3) y1))
  236.      (* (- (car p3) x1) (- (cadr p2) y1))
  237.   )
  238. )
  239.  
  240. ;;;---------------------------------------------------------------------
  241. ;;;Definine Rand()  --which one is better? I don't know.                
  242. ;;;---------------------------------------------------------------------
  243. (defun GetRandFunction(/ scr str) 
  244.   (setq scr (vlax-create-object "ScriptControl"))                       ;Create a script
  245.   (if scr
  246.     (progn
  247.       (vlax-put scr 'Language "VBS")
  248.       (setq str "Randomizen
  249.                 Function Rand(x,y)n
  250.                 Rand=x+Rnd*(y-x)n
  251.                 End Function"
  252.       )                                                                 ;for randomize some features
  253.       (vlax-invoke Scr 'ExecuteStatement str)                           ;Execute script
  254.       (defun Rand (scr nMin nMax)                                       ;Rand function
  255.         (vlax-invoke scr 'run "Rand" nMin nMax)
  256.       )
  257.     )
  258.     ;;;rand function-some code from Le,--thanks.
  259.     (defun Rand (Option nMin nMax / seed)
  260.       (setq seed (getvar "USERR4"))
  261.       (if (= seed 0.)
  262.         (setq seed (getvar "TDUSRTIMER")
  263.               seed (- seed (fix seed))
  264.               seed (rem (* seed 86400) 1)
  265.         )
  266.       )
  267.       (setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
  268.       (setvar "USERR4" seed)
  269.       (+ nMin (* seed (- nMax nMin)))
  270.     )
  271.   )
  272.   scr
  273. )

发表回复

您的电子邮箱地址不会被公开。 必填项已用 * 标注