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

stonedesign

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

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


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

小毛草

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

2. 
   
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"))   ;保存原有颜色
    
24. 
    
25. 
    
26.   (if (< (setq size (getvar "USERR5")) 100.)                            ;初始化衣柜深
    
27.     (progn
    
28.       (setvar "USERR5" 600.)                                            
    
29.       (setq size 600.)
    
30.     )
    
31.   )
    
32. 
    
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.   )
    
48. 
    
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.   )
    
59. 
    
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.       )
    
82. 
    
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))
    
92. 
    
93.       (setq lst3 (OffsetPts lst2 (* (sign dist1) 50) T))
    
94.       (setq Cur3 (make-Poly lst3 T))
    
95.       (setq obj3 (vlax-ename->vla-object Cur3))
    
96. 
    
97.       (setq lst  (list obj1 obj2 obj3))
    
98. 
    
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. )
     
132. 
     
133. ;;;画线段
     
134. (defun Make-Line (p q)
     
135.   (entmakeX (list (cons 0 "LINE") (cons 10 p) (cons 11 q)))
     
136. )
     
137. 
     
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. )
     
170. 
     
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. )
     
179. 
     
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. )
     
189. 
     
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. )
     
201. 
     
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)
     
219. 
     
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))
     
234. 
     
235.         (setq an2 (angle pt2 pt3))
     
236.         (setq pn3 (polar pt2 (+ an2 hPi) d))
     
237.         (setq pn4 (polar pt3 (+ an2 hPi) d))
     
238. 
     
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. )
     
267. 
     
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. )
     
302. 
     
303. 
     
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"))   ;保存原有颜色
     
319. 
     
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.   )
     
365. 
     
366. (command "color" oldcolor)   ;设置为原有颜色
     
367. ;;(setvar "cecolor" "bylayer")  ;设置颜色随层
     
368. 
     
369. ;;(setvar "color" "251")  ;设置颜色随层
     
370. (setvar "clayer" mylayer)
     
371.   (princ)
     
372. )
     

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

stonedesign

感谢: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

lxl217114

这个必须点赞了

注册

这个必须点赞了--

czb203

这个必须点赞了

999999

这个必须点赞了

趣意人生

这个必须点赞了

stonedesign

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

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

stonedesign

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

最高柜子平面也能和衣柜一样设置一侧尺寸