【飞鸟集】画衣柜的LISP程序（更新至2014.11.27)

原来的帖子地址：【飞鸟集】画衣柜的LISP程序（更新至2014.11.27)
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=86629&fromuid=7328064
(出处: 明经CAD社区)


改了一点点看上去好看点，能力有限。希望有大佬在改下。




网友答: 我这也是YG的修改版，不过设置了出入了默认图层


  3. (vl-load-com)
  4. (prompt "命令是YG")
  5. ;;;画衣柜的LISP程序-----------------------------------------------------
  6. ;;;Copyright Highflybird------------------------------------------------
  7. ;;;2011.04.30 ----------------------------------------------------------
  8. (defun c:YG(/ lst doc size pIn str pnt pts scr dlt dist1 dist2 Vec dist
  9.               lst1 lst2 lst3 cur1 cur2 Cur3 obj1 obj2 Obj3 Objs sLen ang1 ang2 ang par
  10.            )
  11. ;;;出错处理
  12. (defun *error* (msg)
  13. (setvar "cecolor""bylayer") ;_ 恢复颜色随层；
  14. (setvar "clayer" mylayer)   ;恢复原有图层
  15. (princ "错误信息: ")
  16. (princ msg)      ;_ 打印错误信息
  17. (princ)         
  18. )
  19. (setvar "measurement" 0)     ; 设置公制单位
  20. (setvar "cmdecho" 0)         ; 关闭命令响应
  21. (setvar "hpassoc" 0)          ;设置填充时不关联
  22. (setq mylayer (getvar "clayer"))    ;保存当前层
  23. (setq oldcolor (getvar "cecolor"))   ;保存原有颜色


  26.   (if (< (setq size (getvar "USERR5")) 100.)                            ;初始化衣柜深
  27.     (progn
  28.       (setvar "USERR5" 600.)                                            
  29.       (setq size 600.)
  30.     )
  31.   )

  33.   ;;获取布置一侧，或设置衣柜深
  34.   (setq str "\n点取布置的一侧[设置(Set)] <走向右侧>:")                  ;获取布置方向
  35.   (initget 8 "Set")
  36.   (setq pIn (getpoint str))
  37.   (while (= pIn "Set")
  38.     (setq size (getvar "USERR5"))
  39.     (initget 14)
  40.     (setq size (getdist (strcat "\n输入衣柜深<" (rtos size) ">:")))     ;如果需要设置衣柜深
  41.     (if (>= size 100)
  42.       (setvar "USERR5" size)
  43.       (setq size (getvar "USERR5"))
  44.     )
  45.     (initget 8 "Set")
  46.     (setq pIn (getpoint str))
  47.   )

  49.   ;;获取靠墙边
  50.   (initget 9)                                                           ;防止空输入，点可在画面外
  51.   (setq pnt (getpoint "\n起点:"))
  52.   (setq pts (cons pnt nil))
  53.   (setq str "\n选取点<回车,空格或右键结束点取>:")
  54.   (while (setq pnt (getpoint (car pts) str))                            ;通过点取方式获得靠墙边
  55.     (setq pnt (list (car pnt) (cadr pnt)))                              ;这步不可少，防止不在同个平面上
  56.     (grdraw pnt (car pts) 3 1)                                          ;虚线显示布置靠墙边
  57.     (setq pts (cons pnt pts))                                   
  58.   )

  60.   ;;输入完成开始画图
  61.   (if (> (length  pts) 1)                                               ;至少要两点
  62.     (progn
  63.       (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  64.       (vla-StartUndoMark doc)                                           ;设置Undo起始点
  65.       (setq scr (GetRandFunction))
  66.       ;;一些初始化工作--------------------------------------------------
  67.       (setq pts (reverse pts))                                          ;点集反转
  68.       ;(setq pts (mapcar (function (lambda (x) (trans x 1 0))) pts))     ;把点集转化到世界坐标系
  69.       (if pIn
  70.         (setq pIn (trans pIn 1 0)
  71.               dlt (det (car pts) (cadr pts) pIn)                        ;右手法则
  72.         )
  73.       )                                                
  74.       (if (> dlt 0)                                                     ;通过右手法则判断偏移方向
  75.         (setq dist1 (* size 0.5)
  76.               dist2 size
  77.         )
  78.         (setq dist1 (* size -0.5)
  79.               dist2 (- size)
  80.         )
  81.       )

  83.       ;;首先构建衣柜的外轮廓和中心线------------------------------------
  84.       (setq lst1 (OffsetPts pts dist1 nil))                             ;衣柜的中心线点
  85.       (setq lst2 (OffsetPts pts dist2 nil))
  86.       (setq lst2 (append pts (reverse lst2)))                           ;衣柜的外轮廓点
  87.       
  88.       (setq Cur1 (make-Poly lst1 nil))                                  ;画衣柜的中心线
  89.       (setq Cur2 (make-Poly lst2 T))                                    ;画衣柜的中心线
  90.       (setq Obj1 (vlax-ename->vla-object Cur1))
  91.       (setq Obj2 (vlax-ename->vla-object Cur2))

  93.       (setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
  94.       (setq Cur3 (make-Poly lst3 T))
  95.       (setq obj3 (vlax-ename->vla-object Cur3))

  97.       (setq lst  (list obj1 obj2 obj3))

  99.       (setq Objs (Make-clothes-hanger))                                 ;画衣架
  100.       (setq dist 0.0)
  101.       (setq sLen (vla-get-length Obj1))                                 ;中心线长度
  102.       (setq ang1 (/ pi 0.1 180))                                        ;摆动幅度在10度左右
  103.       (setq ang2 (- ang1))
  104.       (while (< dist sLen)
  105.         (setq pnt (vlax-curve-getPointAtDist Obj1 dist))                ;衣架的定位点
  106.         (setq par (vlax-curve-getParamAtDist Obj1 dist))
  107.         (setq Vec (vlax-curve-getFirstDeriv Obj1 par))                  ;衣架的水平方向
  108.         (setq ang (angle '(0 0 0) Vec))
  109.         (setq ang (+ ang (Rand scr ang1 ang2)))                         ;衣架的旋转角度
  110.         (setq pIn (vlax-curve-getPointAtParam obj1 (fix (+ 0.5 par))))  ;转点
  111.         (if (>= (distance pnt pIn) 300)                                 ;如果与转点距离大于300
  112.           (Copy-and-tranformby Objs pnt ang)                            ;拷贝原点处衣架并变换
  113.         )        
  114.         (setq dist (+ dist (Rand scr 80 300)))                          ;步进到下一点(100,300)这两个数值可自调
  115.       )
  116.       (mapcar 'vla-erase Objs)                                          ;把原点处衣架删除
  117.       (makeGroup Doc Lst)
  118.       (and scr (vlax-release-object scr))                               ;释放脚本实例
  119.       (vla-EndUndoMark doc)                                             ;设置Undo终止点
  120.       (vlax-release-object doc)
  121.     )
  122.   )
  123.   (redraw)                                                              ;重画一下，消除Grdraw的痕迹
  124. (command "color" oldcolor)   ;设置为原有颜色
  125. ;; (setvar "cecolor" "bylayer")  ;设置颜色随层
  126. (setvar "clayer" mylayer)
  127.   (princ)                                                               ;静默退出
  128. )
  129. (defun sign (x)
  130.   (if (< x 0) -1 1)
  131. )

  133. ;;;画线段
  134. (defun Make-Line (p q)
  135.   (entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
  136. )

  138. ;;;绘制多段线
  139. (defun Make-Poly (pp isClosed / C)
  140. ;;;;;;;;;;;;设置画线层
  141. (if (= (tblsearch "layer" "0-PM-固定家具") nil)
  142.     (Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
  143.     (Command "-layer" "t" "0-PM-固定家具" "")
  144.   )
  145. (setvar "clayer" "0-PM-固定家具")
  146.   (if isClosed
  147.     (setq C 1)
  148.     (setq C 0)
  149.   )
  150.   (entmakeX                                                             ;画凸包
  151.     (append
  152.       (list
  153.         (cons 0 "LWPOLYLINE")
  154.         (cons 100 "AcDbEntity")
  155.         (cons 100 "AcDbPolyline")
  156.         (cons 90 (length pp))                                           ;顶点个数
  157.         (cons 70 C)                                                     ;闭合的
  158.       )
  159.       (mapcar
  160.         (function
  161.           (lambda (x)
  162.             (cons 10 (reverse (cdr (reverse (trans x 1 0)))))
  163.           )
  164.         )
  165.         pp
  166.       )                                                                   ;多段线顶点
  167.     )
  168.   )
  169. )

  171. ;;;画衣架
  172. (defun Make-clothes-hanger (/)
  173.   (mapcar
  174.     (function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
  175.     '((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
  176.     '((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
  177.   )
  178. )

  180. ;;;拷贝原点处的物体并变换
  181. (defun Copy-and-tranformby (Objs pnt Ang / newObj)
  182.   (foreach obj Objs
  183.     (setq NewObj (vla-copy obj))
  184.     (vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
  185.     (vla-rotate NewObj (vlax-3d-point pnt) Ang)
  186.     (setq lst (cons NewObj lst))
  187.   )
  188. )

  190. ;;;最后做成组
  191. (defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
  192.   (setq Groups (vla-get-groups doc))
  193.   (setq sGroup (getvar "cdate"))
  194.   (setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
  195.   (setq oGroup (vla-add Groups (strcat "YG" sGroup)))
  196.   (setq aBound (cons 0  (1- (length objLst))))
  197.   (setq eArray (vlax-make-safearray vlax-vbObject aBound))
  198.   (vlax-safearray-fill eArray objLst)
  199.   (vla-AppendItems oGroup eArray)
  200. )

  202. ;;;偏移点集(没用vla-offset)
  203. ;;;此函数可以扩展，为以后的编程准备
  204. (defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
  205.   (setq ppp pts)
  206.   (setq cnt (length ppp))
  207.   (cond
  208.     ( (>= cnt 2)
  209.       (setq hPi (/ Pi 2))
  210.      
  211.       (setq pt1 (car ppp))
  212.       (setq pt2 (cadr ppp))
  213.      
  214.       (setq an1 (angle pt1 pt2))
  215.       (setq pn1 (polar pt1 (+ an1 hPi) d))
  216.       (setq pn2 (polar pt2 (+ an1 hPi) d))
  217.      
  218.       (setq pn4 pn2)

  220.       (setq lst (list pn1))
  221.       (if isClosed
  222.         (setq ppp (append pts (list (car pts)))
  223.               p12 (list pn1 pn2)
  224.         )
  225.       )
  226.       (while (caddr ppp)
  227.         (setq pt1 (car ppp))
  228.         (setq pt2 (cadr ppp))
  229.         (setq pt3 (caddr ppp))
  230.    
  231.         (setq an1 (angle pt1 pt2))
  232.         (setq pn1 (polar pt1 (+ an1 hPi) d))
  233.         (setq pn2 (polar pt2 (+ an1 hPi) d))

  235.         (setq an2 (angle pt2 pt3))
  236.         (setq pn3 (polar pt2 (+ an2 hPi) d))
  237.         (setq pn4 (polar pt3 (+ an2 hPi) d))

  239.         (setq pnt (inters pn1 pn2 pn3 pn4 nil))
  240.         (and  pnt (setq lst (cons pnt lst)))
  241.         (setq ppp (cdr ppp))
  242.       )
  243.       (if isClosed
  244.         (setq lst (cdr (reverse lst))
  245.               pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
  246.               lst (cons pnt lst)
  247.         )
  248.         (setq lst (cons pn4 lst)
  249.               lst (reverse lst)
  250.         )
  251.       )
  252.       (vl-remove nil lst)
  253.     )  
  254.   )
  255. )
  256. ;;;===============
  257. ;;;行列式,判别法则
  258. ;;;===============
  259. (defun det (p1 p2 p3 / x1 y1)
  260.   (setq x1 (car p1)
  261.         y1 (cadr p1)
  262.   )
  263.   (- (* (- (car p2) x1) (- (cadr p3) y1))
  264.      (* (- (car p3) x1) (- (cadr p2) y1))
  265.   )
  266. )

  268. ;;;---------------------------------------------------------------------
  269. ;;;Definine Rand()  --which one is better? I don't know.               
  270. ;;;---------------------------------------------------------------------
  271. (defun GetRandFunction(/ scr str)
  272.   (setq scr (vlax-create-object "ScriptControl"))                       ;Create a script
  273.   (if scr
  274.     (progn
  275.       (vlax-put scr 'Language "VBS")
  276.       (setq str "Randomize\n
  277.                 Function Rand(x,y)\n
  278.                 Rand=x+Rnd*(y-x)\n
  279.                 End Function"
  280.       )                                                                 ;for randomize some features
  281.       (vlax-invoke Scr 'ExecuteStatement str)                           ;Execute script
  282.       (defun Rand (scr nMin nMax)                                       ;Rand function
  283.         (vlax-invoke scr 'run "Rand" nMin nMax)
  284.       )
  285.     )
  286.     ;;;rand function-some code from Le,--thanks.
  287.     (defun Rand (Option nMin nMax / seed)
  288.       (setq seed (getvar "USERR4"))
  289.       (if (= seed 0.)
  290.         (setq seed (getvar "TDUSRTIMER")
  291.               seed (- seed (fix seed))
  292.               seed (rem (* seed 86400) 1)
  293.         )
  294.       )
  295.       (setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
  296.       (setvar "USERR4" seed)
  297.       (+ nMin (* seed (- nMax nMin)))
  298.     )
  299.   )
  300.   scr
  301. )


  304. ;;;;;;;;;;;柜子平面
  305. ;坛子里找个简单代码,类似达到效果
  306. (defun c:SG ( / _line )
  307. (defun *error* (msg)
  308. (setvar "cecolor""bylayer") ;_ 恢复颜色随层；
  309. (setvar "clayer" mylayer)   ;恢复原有图层
  310. (princ "错误信息: ")
  311. (princ msg)      ;_ 打印错误信息
  312. (princ)         
  313. )
  314. (setvar "measurement" 0)     ; 设置公制单位
  315. (setvar "cmdecho" 0)         ; 关闭命令响应
  316. (setvar "hpassoc" 0)          ;设置填充时不关联
  317. (setq mylayer (getvar "clayer"))    ;保存当前层
  318. (setq oldcolor (getvar "cecolor"))   ;保存原有颜色

  320. (defun _line (lst)
  321. (if (= (tblsearch "layer" "0-PM-固定家具") nil)
  322.     (Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
  323.     (Command "-layer" "t" "0-PM-固定家具" "")
  324.   )
  325. (setvar "clayer" "0-PM-固定家具")
  326.     (mapcar '(lambda (a b)(entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))) lst (cdr lst))
  327.   )
  328.   (while (and (setq n (Cond ((getint(strcat "\n等分数["(itoa(setq n(Cond ( n )( 5 ))))"] ")))( n )))
  329.               (setq p1 (getpoint "\n第一角点 :"))
  330.               (setq p2 (getcorner p1 "\n另一角点 :"))
  331.          )
  332.     (setq dx (abs (- (car p2) (car p1)))
  333.           dy (abs (- (cadr p2) (cadr p1)))
  334.     )
  335.     (setq ptm (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2)))
  336.           p2  (list (max (car p1) (car p2)) (max (cadr p1) (cadr p2)))
  337.           p1  ptm
  338.     )
  339.     (if        (> dx dy)
  340.       (progn
  341.         (setq dd (/ dx n))
  342.         (repeat        n
  343.           (setq        p3 (polar p1 0 dd)
  344.                 p4 (polar p1 (/ pi 2) dy)
  345.                 p5 (polar p4 0 dd)
  346.           )
  347.           (_LINE (list p1 p3 p4 p5 p1 p4))
  348.           (setq p1 p3)
  349.         )
  350.       )
  351.       (progn
  352.         (setq dd (/ dy n))
  353.         (repeat        n
  354.           (setq        p3 (polar p1 (/ pi 2) dd)
  355.                 p4 (polar p1 0 dx)
  356.                 p5 (polar p3 0 dx)
  357.           )
  358.           (_LINE (list p1 p3 p4 p5 p1 p4))
  359.           (setq p1 p3)
  360.         )
  361.       )
  362.     )
  363.     (_LINE (list p3 p5))
  364.   )

  366. (command "color" oldcolor)   ;设置为原有颜色
  367. ;;(setvar "cecolor" "bylayer")  ;设置颜色随层

  369. ;;(setvar "color" "251")  ;设置颜色随层
  370. (setvar "clayer" mylayer)
  371.   (princ)
  372. )


网友答:
小毛草 发表于 2022-6-24 11:11
我这也是YG的修改版，不过设置了出入了默认图层

呵呵，厉害就是需要这个，衣柜没啥问题了，但是那个个柜子平面不这么好用 不能设置一侧的距离，随意2点画的，不是很好用，大佬能改下？改成图片的效果

网友答: 感谢: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的修改版，不过设置了出入了默认图层

最高柜子平面也能和衣柜一样设置一侧尺寸
  • 上一篇：就是一个绘制起拱橱柜门的程序
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025