明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 501|回复: 10

[讨论] 修改 原【高飞鸟】] 【飞鸟集】画衣柜的LISP程序的画平面衣柜

[复制链接]
发表于 2022-6-22 11:44 | 显示全部楼层 |阅读模式
【飞鸟集】画衣柜的LISP程序(更新至2014.11.27)

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


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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 2明经币 +2 收起 理由
lxl217114 + 1 很给力!石头哥
USER2128 + 1 赞一个!

查看全部评分

发表于 2022-6-24 11:11 | 显示全部楼层
我这也是YG的修改版,不过设置了出入了默认图层


  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. ;;;出错处理
  10. (defun *error* (msg)
  11. (setvar "cecolor""bylayer") ;_ 恢复颜色随层;
  12. (setvar "clayer" mylayer)   ;恢复原有图层
  13. (princ "错误信息: ")
  14. (princ msg)      ;_ 打印错误信息
  15. (princ)         
  16. )
  17. (setvar "measurement" 0)     ; 设置公制单位
  18. (setvar "cmdecho" 0)         ; 关闭命令响应
  19. (setvar "hpassoc" 0)          ;设置填充时不关联
  20. (setq mylayer (getvar "clayer"))    ;保存当前层
  21. (setq oldcolor (getvar "cecolor"))   ;保存原有颜色


  22.   (if (< (setq size (getvar "USERR5")) 100.)                            ;初始化衣柜深
  23.     (progn
  24.       (setvar "USERR5" 600.)                                            
  25.       (setq size 600.)
  26.     )
  27.   )

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

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

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

  75.       ;;首先构建衣柜的外轮廓和中心线------------------------------------
  76.       (setq lst1 (OffsetPts pts dist1 nil))                             ;衣柜的中心线点
  77.       (setq lst2 (OffsetPts pts dist2 nil))
  78.       (setq lst2 (append pts (reverse lst2)))                           ;衣柜的外轮廓点
  79.       
  80.       (setq Cur1 (make-Poly lst1 nil))                                  ;画衣柜的中心线
  81.       (setq Cur2 (make-Poly lst2 T))                                    ;画衣柜的中心线
  82.       (setq Obj1 (vlax-ename->vla-object Cur1))
  83.       (setq Obj2 (vlax-ename->vla-object Cur2))

  84.       (setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
  85.       (setq Cur3 (make-Poly lst3 T))
  86.       (setq obj3 (vlax-ename->vla-object Cur3))

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

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

  121. ;;;画线段
  122. (defun Make-Line (p q)
  123.   (entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
  124. )

  125. ;;;绘制多段线
  126. (defun Make-Poly (pp isClosed / C)
  127. ;;;;;;;;;;;;设置画线层
  128. (if (= (tblsearch "layer" "0-PM-固定家具") nil)
  129.     (Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
  130.     (Command "-layer" "t" "0-PM-固定家具" "")
  131.   )
  132. (setvar "clayer" "0-PM-固定家具")
  133.   (if isClosed
  134.     (setq C 1)
  135.     (setq C 0)
  136.   )
  137.   (entmakeX                                                             ;画凸包
  138.     (append
  139.       (list
  140.         (cons 0 "LWPOLYLINE")
  141.         (cons 100 "AcDbEntity")
  142.         (cons 100 "AcDbPolyline")
  143.         (cons 90 (length pp))                                           ;顶点个数
  144.         (cons 70 C)                                                     ;闭合的
  145.       )
  146.       (mapcar
  147.         (function
  148.           (lambda (x)
  149.             (cons 10 (reverse (cdr (reverse (trans x 1 0)))))
  150.           )
  151.         )
  152.         pp
  153.       )                                                                   ;多段线顶点
  154.     )
  155.   )
  156. )

  157. ;;;画衣架
  158. (defun Make-clothes-hanger (/)
  159.   (mapcar
  160.     (function (lambda (p q /) (VLAX-ENAME->VLA-OBJECT (make-line p q))))
  161.     '((-17.5 -225.) (+17.5 -225.) (-35.0 -210.) (-35.0 +210.))
  162.     '((-17.5 +225.) (+17.5 +225.) (+35.0 -210.) (+35.0 +210.))
  163.   )
  164. )

  165. ;;;拷贝原点处的物体并变换
  166. (defun Copy-and-tranformby (Objs pnt Ang / newObj)
  167.   (foreach obj Objs
  168.     (setq NewObj (vla-copy obj))
  169.     (vla-move NewObj (vlax-3d-point '(0 0 0)) (vlax-3d-point pnt))
  170.     (vla-rotate NewObj (vlax-3d-point pnt) Ang)
  171.     (setq lst (cons NewObj lst))
  172.   )
  173. )

  174. ;;;最后做成组
  175. (defun MakeGroup (Doc objLst / Groups sGroup oGroup aBound eArray)
  176.   (setq Groups (vla-get-groups doc))
  177.   (setq sGroup (getvar "cdate"))
  178.   (setq sGroup (rtos (* 1e9 (- sGroup (fix sGroup))) 2 0))
  179.   (setq oGroup (vla-add Groups (strcat "YG" sGroup)))
  180.   (setq aBound (cons 0  (1- (length objLst))))
  181.   (setq eArray (vlax-make-safearray vlax-vbObject aBound))
  182.   (vlax-safearray-fill eArray objLst)
  183.   (vla-AppendItems oGroup eArray)
  184. )

  185. ;;;偏移点集(没用vla-offset)
  186. ;;;此函数可以扩展,为以后的编程准备
  187. (defun OffsetPts (pts d isClosed / AN1 AN2 CNT HPI LST PN1 PN2 PN3 PN4 PNT PPP PT1 PT2 PT3 P12)
  188.   (setq ppp pts)
  189.   (setq cnt (length ppp))
  190.   (cond
  191.     ( (>= cnt 2)
  192.       (setq hPi (/ Pi 2))
  193.      
  194.       (setq pt1 (car ppp))
  195.       (setq pt2 (cadr ppp))
  196.      
  197.       (setq an1 (angle pt1 pt2))
  198.       (setq pn1 (polar pt1 (+ an1 hPi) d))
  199.       (setq pn2 (polar pt2 (+ an1 hPi) d))
  200.      
  201.       (setq pn4 pn2)

  202.       (setq lst (list pn1))
  203.       (if isClosed
  204.         (setq ppp (append pts (list (car pts)))
  205.               p12 (list pn1 pn2)
  206.         )
  207.       )
  208.       (while (caddr ppp)
  209.         (setq pt1 (car ppp))
  210.         (setq pt2 (cadr ppp))
  211.         (setq pt3 (caddr ppp))
  212.    
  213.         (setq an1 (angle pt1 pt2))
  214.         (setq pn1 (polar pt1 (+ an1 hPi) d))
  215.         (setq pn2 (polar pt2 (+ an1 hPi) d))

  216.         (setq an2 (angle pt2 pt3))
  217.         (setq pn3 (polar pt2 (+ an2 hPi) d))
  218.         (setq pn4 (polar pt3 (+ an2 hPi) d))

  219.         (setq pnt (inters pn1 pn2 pn3 pn4 nil))
  220.         (and  pnt (setq lst (cons pnt lst)))
  221.         (setq ppp (cdr ppp))
  222.       )
  223.       (if isClosed
  224.         (setq lst (cdr (reverse lst))
  225.               pnt (inters pn3 pn4 (car p12) (cadr p12) nil)
  226.               lst (cons pnt lst)
  227.         )
  228.         (setq lst (cons pn4 lst)
  229.               lst (reverse lst)
  230.         )
  231.       )
  232.       (vl-remove nil lst)
  233.     )  
  234.   )
  235. )
  236. ;;;===============
  237. ;;;行列式,判别法则
  238. ;;;===============
  239. (defun det (p1 p2 p3 / x1 y1)
  240.   (setq x1 (car p1)
  241.         y1 (cadr p1)
  242.   )
  243.   (- (* (- (car p2) x1) (- (cadr p3) y1))
  244.      (* (- (car p3) x1) (- (cadr p2) y1))
  245.   )
  246. )

  247. ;;;---------------------------------------------------------------------
  248. ;;;Definine Rand()  --which one is better? I don't know.               
  249. ;;;---------------------------------------------------------------------
  250. (defun GetRandFunction(/ scr str)
  251.   (setq scr (vlax-create-object "ScriptControl"))                       ;Create a script
  252.   (if scr
  253.     (progn
  254.       (vlax-put scr 'Language "VBS")
  255.       (setq str "Randomize\n
  256.                 Function Rand(x,y)\n
  257.                 Rand=x+Rnd*(y-x)\n
  258.                 End Function"
  259.       )                                                                 ;for randomize some features
  260.       (vlax-invoke Scr 'ExecuteStatement str)                           ;Execute script
  261.       (defun Rand (scr nMin nMax)                                       ;Rand function
  262.         (vlax-invoke scr 'run "Rand" nMin nMax)
  263.       )
  264.     )
  265.     ;;;rand function-some code from Le,--thanks.
  266.     (defun Rand (Option nMin nMax / seed)
  267.       (setq seed (getvar "USERR4"))
  268.       (if (= seed 0.)
  269.         (setq seed (getvar "TDUSRTIMER")
  270.               seed (- seed (fix seed))
  271.               seed (rem (* seed 86400) 1)
  272.         )
  273.       )
  274.       (setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
  275.       (setvar "USERR4" seed)
  276.       (+ nMin (* seed (- nMax nMin)))
  277.     )
  278.   )
  279.   scr
  280. )


  281. ;;;;;;;;;;;柜子平面
  282. ;坛子里找个简单代码,类似达到效果
  283. (defun c:SG ( / _line )
  284. (defun *error* (msg)
  285. (setvar "cecolor""bylayer") ;_ 恢复颜色随层;
  286. (setvar "clayer" mylayer)   ;恢复原有图层
  287. (princ "错误信息: ")
  288. (princ msg)      ;_ 打印错误信息
  289. (princ)         
  290. )
  291. (setvar "measurement" 0)     ; 设置公制单位
  292. (setvar "cmdecho" 0)         ; 关闭命令响应
  293. (setvar "hpassoc" 0)          ;设置填充时不关联
  294. (setq mylayer (getvar "clayer"))    ;保存当前层
  295. (setq oldcolor (getvar "cecolor"))   ;保存原有颜色

  296. (defun _line (lst)
  297. (if (= (tblsearch "layer" "0-PM-固定家具") nil)
  298.     (Command "-layer" "m" "0-PM-固定家具" "c" 251 "" "")
  299.     (Command "-layer" "t" "0-PM-固定家具" "")
  300.   )
  301. (setvar "clayer" "0-PM-固定家具")
  302.     (mapcar '(lambda (a b)(entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b)))) lst (cdr lst))
  303.   )
  304.   (while (and (setq n (Cond ((getint(strcat "\n等分数["(itoa(setq n(Cond ( n )( 5 ))))"] ")))( n )))
  305.               (setq p1 (getpoint "\n第一角点 :"))
  306.               (setq p2 (getcorner p1 "\n另一角点 :"))
  307.          )
  308.     (setq dx (abs (- (car p2) (car p1)))
  309.           dy (abs (- (cadr p2) (cadr p1)))
  310.     )
  311.     (setq ptm (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2)))
  312.           p2  (list (max (car p1) (car p2)) (max (cadr p1) (cadr p2)))
  313.           p1  ptm
  314.     )
  315.     (if        (> dx dy)
  316.       (progn
  317.         (setq dd (/ dx n))
  318.         (repeat        n
  319.           (setq        p3 (polar p1 0 dd)
  320.                 p4 (polar p1 (/ pi 2) dy)
  321.                 p5 (polar p4 0 dd)
  322.           )
  323.           (_LINE (list p1 p3 p4 p5 p1 p4))
  324.           (setq p1 p3)
  325.         )
  326.       )
  327.       (progn
  328.         (setq dd (/ dy n))
  329.         (repeat        n
  330.           (setq        p3 (polar p1 (/ pi 2) dd)
  331.                 p4 (polar p1 0 dx)
  332.                 p5 (polar p3 0 dx)
  333.           )
  334.           (_LINE (list p1 p3 p4 p5 p1 p4))
  335.           (setq p1 p3)
  336.         )
  337.       )
  338.     )
  339.     (_LINE (list p3 p5))
  340.   )

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

  343. ;;(setvar "color" "251")  ;设置颜色随层
  344. (setvar "clayer" mylayer)
  345.   (princ)
  346. )

评分

参与人数 1明经币 +1 金钱 +5 收起 理由
stonedesign + 1 + 5 赞一个!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

发表于 2022-6-23 12:33 | 显示全部楼层
这个必须点赞了
发表于 2022-6-23 13:11 | 显示全部楼层
这个必须点赞了--
发表于 2022-6-23 17:07 | 显示全部楼层

这个必须点赞了
发表于 2022-6-23 21:23 | 显示全部楼层
这个必须点赞了
发表于 2022-6-23 22:38 | 显示全部楼层

这个必须点赞了
 楼主| 发表于 2022-6-24 12:22 | 显示全部楼层
小毛草 发表于 2022-6-24 11:11
我这也是YG的修改版,不过设置了出入了默认图层

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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2022-6-24 12:31 | 显示全部楼层
小毛草 发表于 2022-6-24 11:11
我这也是YG的修改版,不过设置了出入了默认图层

最高柜子平面也能和衣柜一样设置一侧尺寸
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2022 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2022-6-30 14:55 , Processed in 0.190758 second(s), 25 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表