[lostbalance]我的通用函数库wyb-函数

lostbalance

个人在用的函数库，部分自己编的，部分抄袭、借鉴明经或网上大神的。论坛中我发布的程序，需要的源码可以在这里找找。

（说明下，关于函数名wyb，仅是为了便于个人编程查找引用方便，在函数版次中注明了原作者，如有问题请联系我。）

---

首先是预定义的几个全局参数。
论坛的代码模块好像有点问题，显示不正常，我占个二楼放吧。

目录

1. (wyb-get-box ename)//4.2. 取得图元外矩形框
   
2. (wyb-get-mBox ss)//4.2.2 取得选择集内不重叠的外矩形框
   
3. (wyb-sort-lst lst key fuzz func)//4.4. 列表排序基础函数(方向判断)
   
4. (wyb-sort-ssPts sspts key fuzz)//4.4.1 图元排序
   
5. (wyb-sort-pts pts dir xyz fuzz)//4.4.2 点列表排序
   
6. (wyb-get-entDxf dxf ent)//4.11. 获取对象dxf码
   
7. (wyb-lst-position a lst)//4.18. a在表lst中的位置 or nil
   
8. (wyb-sublst lst start len)//4.21. 提取列表的一部分，类似substr(迭代法)
   
9. (wyb-substNth new n lst)//4.22. 替换列表中指定位置的项
   
10. (wyb-file-getFolder msg)//4.38. 获取文件夹
    
11. (wyb-getDesktop)//4.48. 获取桌面desktop的路径
    
12. (wyb-subst ent dxf new_item)//6.5 替换新旧列表后的列表
    
13. (wyb-findSupportFolder folder)//9.24. 在支持目录中查找文件夹路径
    
14. (wyb-get-lastEnt ent)//3.17. 获取ent之后的所有对象
    
15. (wyb-substMod ent dxf new_item)//5.10.1 替换并更新新旧列表后的列表
    
16. (wyb-subst ent dxf new_item)//5.10. 替换新旧列表后的列表
    
17. (wyb-name obj)//9.6. 对象名称
    
18. (wyb-listCollectionMemberNames collection)//9.11. 返回集合成员名称列表
    
19. (wyb-listLayers)//9.13. 返回层集合成员名称列表
    

复制代码

---

20181214 补充wyb-if类的函数，见本贴13楼
20181217 增加wyb-findSupportFolder
                 PS，生命在于折腾，前阵子整理了一下函数库，重新分类梳理了编号，有极个别函数的名称也调整了下，有问题请留言
20190530 补充wyb-subst v1.0，wyb-substMod v1.0，wyb-get-lastEnt v1.0
20191216 补充wyb-name v1.0, wyb-listCollectionMemberNames v1.0, wyb-listLayers v1.020200916 补充wyb-lst-insertNth v1.0
20210802 补充wyb-sort-str v1.0

lostbalance

;|=====WYB函数库=====
--------------------------------------------------------------------------------
本函数库的源码，有部分源自明经论坛、晓东论坛等处
由于各种原因，导致部分源码的作者信息不完整或丢失，深感歉意
感谢自贡黄明儒、highflybir、llsheng-73、edata、不死猫等明经er和leemac等
--------------------------------------------------------------------------------
====================|;
(vl-load-com)
;===0. 常数
(setq ;;常用VLA对象、集合
    0.5pi   (* 0.5 pi)
    1.5pi   (* 1.5 pi)
    2pi     (+ pi pi)
    *ACAD*  (vlax-get-acad-object) ;;AutoCAD任务中的顶层 AutoCAD应用程序对象，即获取AutoCAD程序本身
    *DOC*   (vla-get-ActiveDocument *ACAD*) ;;是在autocad程序下面运行的当前文档对象
    *LOUT*  (vla-get-ActiveLayout *DOC*) ;;激活的布局
    *DOCS*  (vla-get-Documents *ACAD*)
    *MS*    (vla-get-modelSpace *DOC*)
    *PS*    (vla-get-paperSpace *DOC*)
    *BLKS*  (vla-get-Blocks *DOC*)
    *LAYS*  (vla-get-Layers *DOC*)
    *LTS*   (vla-get-Linetypes *DOC*)
    *TSS*   (vla-get-TextStyles *DOC*)
    *GRPS*  (vla-get-groups *DOC*)
    *DIMS*  (vla-get-DimStyles *DOC*)
    *LOUTS* (vla-get-Layouts *DOC*)
    *VPS*   (vla-get-Viewports *DOC*)
    *VS*    (vla-get-Views *DOC*)
    *DICS*  (vla-get-Dictionaries *DOC*)
    *PLTCS* (vla-get-PlotConfigurations *DOC*)
    *RAPPS* (vla-get-RegisteredApplications *DOC*)
    ;;常用的几个外部接口对象
    *FSO*   (vlax-get-or-create-object "Scripting.FileSystemObject")
    *WSH*   (vlax-get-or-create-object "wscript.shell")
    *SHELL* (vlax-get-or-create-object "Shell.Application")
    *SCR*   (vlax-get-or-create-object "ScriptControl")
    *WBEM*  (vlax-get-or-create-object "WbemScripting.SWbemLocator")
    *VBS*   (vlax-get-or-create-object "VBScript.regexp")
    *HTMLF* (vlax-get-or-create-object "htmlfile")
    ;;全局参数
    *wyb_ini* "WYB-Tools.ini"
)

xiewu

如能合并就方便了
你真好

lostbalance

补充wyb-if类的函数。
都算是比较简单和通用的函数，就不挂附件了，直接贴出来。

2. ;|= 3.5. 判断是否val对象
   
3. @== (wyb-if-vlaObject obj)
   
4. #== return: t / nil
   
5. ====================|;
   
6. (defun wyb-if-vlaObject (@obj)
   
7.     (equal (type @obj) 'vla-object)
   
8. )
   
9. ;|= 3.6. 判断是否字符串
   
10. @== (wyb-if-string x)
    
11. #== return: t / nil
    
12. ====================|;
    
13. (defun wyb-if-string (@x)
    
14.     (equal (type @x) 'str)
    
15. )
    
16. ;|= 3.7. 判断是否实数
    
17. @== (wyb-if-real x)
    
18. #== return: t / nil
    
19. ====================|;
    
20. (defun wyb-if-real (@x)
    
21.     (equal (type @x) 'real)
    
22. )
    
23. ;|= 3.8. 判断是否ename对象
    
24. @== (wyb-if-ename x)
    
25. #== return: t / nil
    
26. ====================|;
    
27. (defun wyb-if-ename (@x)
    
28.     (equal (type @x) 'ename)
    
29. )
    
30. ;|= 3.9. 判断是否变体
    
31. @== (wyb-if-variant x)
    
32. #== return: t / nil
    
33. ====================|;
    
34. (defun wyb-if-variant (@x)
    
35.     (equal (type @x) 'variant)
    
36. )
    
37. ;|= 3.10. 判断是否是选择集且长度不为0
    
38. @== (wyb-if-ssp ss)
    
39. #== return: t / nil
    
40. ====================|;
    
41. (defun wyb-if-ssp (@ss)
    
42.     (and (= (type @ss) 'PICKSET) (> (sslength @ss) 0))
    
43. )
    
44. ;|= 3.11. 判断是否为点对表
    
45. @== (wyb-if-consp lst)
    
46. #== return: t / nil
    
47. ====================|;
    
48. (defun wyb-if-consp (@lst)
    
49.     (and (vl-consp @lst)(not (vl-list-length @lst)))
    
50. )
    
51. ;|= 3.12. 判断是否为整数
    
52. @== (wyb-if-int x)
    
53. #== return: t / nil
    
54. ====================|;
    
55. (defun wyb-if-int (@x)
    
56.     (= (type @x) 'INT)
    
57. )
    
58. ;|= 3.13. 判断是否为整数或整实数
    
59. @== (wyb-if-int2 x)
    
60. #== return: t / nil
    
61. ====================|;
    
62. (defun wyb-if-int2 (@x)
    
63.     (= (fix @x) @x)
    
64. )
    
65. ;|= 3.14. 判断字符串首字符是否中文字符
    
66. @== (wyb-if-chiCh str)
    
67. #== return: T / nil
    
68. par:
    
69. sample:
    
70.     (wyb-if-chiCh "好")  ;;return: T
    
71.     (wyb-if-chiCh "1")   ;;return: nil
    
72. ver:
    
73.     [1.0] by woyb 20170425
    
74. ====================|;
    
75. (defun wyb-if-chiCh (@str)
    
76.     (> (ascii (substr @str 1 1)) 127)
    
77. )

;|= 3.5. 判断是否val对象<br /> @== (wyb-if-vlaObject obj)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-vlaObject (@obj) <br />     (equal (type @obj) 'vla-object)<br /> )<br /> ;|= 3.6. 判断是否字符串<br /> @== (wyb-if-string x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-string (@x) <br />     (equal (type @x) 'str)<br /> )<br /> ;|= 3.7. 判断是否实数<br /> @== (wyb-if-real x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-real (@x) <br />     (equal (type @x) 'real)<br /> )<br /> ;|= 3.8. 判断是否ename对象<br /> @== (wyb-if-ename x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-ename (@x)<br />     (equal (type @x) 'ename)<br /> )<br /> ;|= 3.9. 判断是否变体<br /> @== (wyb-if-variant x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-variant (@x) <br />     (equal (type @x) 'variant)<br /> )<br /> ;|= 3.10. 判断是否是选择集且长度不为0<br /> @== (wyb-if-ssp ss)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-ssp (@ss) <br />     (and (= (type @ss) 'PICKSET) (> (sslength @ss) 0))<br /> )<br /> ;|= 3.11. 判断是否为点对表<br /> @== (wyb-if-consp lst)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-consp (@lst)<br />     (and (vl-consp @lst)(not (vl-list-length @lst)))<br /> )<br /> ;|= 3.12. 判断是否为整数<br /> @== (wyb-if-int x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-int (@x) <br />     (= (type @x) 'INT)<br /> )<br /> ;|= 3.13. 判断是否为整数或整实数<br /> @== (wyb-if-int2 x)<br /> #== return: t / nil<br /> ====================|;<br /> (defun wyb-if-int2 (@x) <br />     (= (fix @x) @x)<br /> )<br /> ;|= 3.14. 判断字符串首字符是否中文字符<br /> @== (wyb-if-chiCh str)<br /> #== return: T / nil<br /> par: <br /> sample: <br />     (wyb-if-chiCh "好")  ;;return: T<br />     (wyb-if-chiCh "1")   ;;return: nil<br /> ver: <br />     [1.0] by woyb 20170425<br /> ====================|;<br /> (defun wyb-if-chiCh (@str)<br />     (> (ascii (substr @str 1 1)) 127)<br /> )

BaoWSE

悟性不达标，先收藏之有时间再慢慢琢磨参悟！

sachindkini

dear sir

wow its amazing

thanks for sharing

ynhh

如能合并就方便了
你真好

pannelchen

收藏以后学习用.

yoyoho

感谢分享学习!!!!!

fangmin723

优化内容：
1、单个图元无法创建包围框。
2、如果有多行文字时，多行文字外框超过文字内容时，无法准确识别（见截图代码下面的截图）。

优化后代码：
部分代码取自：KozMos AnnoQuarX Functions

1. (defun c:mBox (/ A B BOX C ent FLAG INTERSECT L L1 N RECTANG SS)
   
2.   (defun box (e / b enx h j l lst n o obj p1 p2 p3 p4 r w xylst)
   
3.     (setq enx (entget e))
   
4.     (if (or (= "MTEXT" (cdr (assoc 0 enx))) (= "TEXT" (cdr (assoc 0 enx))))
   
5.       (progn
   
6.         (setq  l
   
7.           (cond
   
8.             ((= "TEXT" (cdr (assoc 0 enx)))
   
9.               (setq
   
10.                 b (cdr (assoc 10 enx))
    
11.                 r (cdr (assoc 50 enx))   
    
12.                 l (textbox enx)      
    
13.                 n (cdr (assoc 210 enx))   
    
14.               )
    
15.               (list
    
16.                 (list (caar l) (cadar l))   
    
17.                 (list (caadr l) (cadar l))
    
18.                 (list (caadr l) (cadadr l))
    
19.                 (list (caar l) (cadadr l))
    
20.               )
    
21.             )
    
22.             ((= "MTEXT" (cdr (assoc 0 enx)))
    
23.               (setq
    
24.                 n (cdr (assoc 210 enx))
    
25.                 b (trans (cdr (assoc 10 enx)) 0 n)
    
26.                 r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))
    
27.                 w (cdr (assoc 42 enx))
    
28.                 h (cdr (assoc 43 enx))
    
29.                 j (cdr (assoc 71 enx))
    
30.                 o (list
    
31.                     (cond
    
32.                       ((member j '(2 5 8)) (/ w -2.0))
    
33.                       ((member j '(3 6 9)) (- w))
    
34.                       (0.0)
    
35.                     )
    
36.                     (cond
    
37.                       ((member j '(1 2 3)) (- h))
    
38.                       ((member j '(4 5 6)) (/ h -2.0))
    
39.                       (0.0)
    
40.                      
    
41.                     )
    
42.                   )
    
43.               )
    
44.               (list
    
45.                 (list (car o) (cadr o))
    
46.                 (list (+ (car o) w) (cadr o))
    
47.                 (list (+ (car o) w) (+ (cadr o) h))
    
48.                 (list (car o) (+ (cadr o) h))
    
49.               )
    
50.             )
    
51.           )
    
52.         )
    
53.         (setq l
    
54.           (
    
55.             (lambda (m)
    
56.               (mapcar
    
57.                 '(lambda (p)
    
58.                    (mapcar '+ (mapcar '(lambda (r) (apply '+ (mapcar '* r p))) m) b)
    
59.                  )
    
60.                 l
    
61.               )
    
62.             )
    
63.             (list
    
64.               (list (cos r) (sin (- r)) 0.0)
    
65.               (list (sin r) (cos r) 0.0)
    
66.               '(0.0 0.0 1.0)
    
67.             )
    
68.           )
    
69.         )
    
70.         (setq
    
71.           xylst (apply 'mapcar (cons 'list (mapcar '(lambda (x) (trans x n 0)) l)))
    
72.           p1 (list (apply 'min (car xylst)) (apply 'min (cadr xylst)))
    
73.           p3 (list (apply 'max (car xylst)) (apply 'max (cadr xylst)))
    
74.         )
    
75.       )
    
76.       (progn
    
77.         (setq obj (vlax-ename->vla-object e))
    
78.         (vla-GetBoundingBox obj 'p1 'p3)
    
79.         (setq p1 (vlax-safearray->list p1)
    
80.           p3 (vlax-safearray->list p3)
    
81.           p2 (list (car p1) (cadr p3) (caddr p1))
    
82.           p4 (list (car p3) (cadr p1) (caddr p1))
    
83.         )
    
84.         (if  (= "SPLINE" (cdr (assoc 0 enx)))
    
85.           (progn
    
86.             (setq lst
    
87.               (mapcar '(lambda(a b)
    
88.                          (vlax-curve-getClosestPointToProjection e a b t)
    
89.                        )
    
90.                 (list p1 p2 p3 p4)
    
91.                 '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
    
92.               )
    
93.             )
    
94.             (setq
    
95.               p1 (apply 'mapcar (cons 'min lst))
    
96.               p3 (apply 'mapcar (cons 'max lst))
    
97.             )
    
98.           )
    
99.         )
    
100.       )
     
101.     )
     
102.     (list p1 p3)
     
103.   )
     
104.   (defun intersect (a b)
     
105.     (if
     
106.       (or
     
107.         (and
     
108.           (<= (caar a) (caar b) (caadr a))
     
109.           (<= (cadar a) (cadar b) (cadadr a))
     
110.         )
     
111.         (and
     
112.           (<= (caar a) (caar b) (caadr a))
     
113.           (<= (cadar a) (cadadr b) (cadadr a))
     
114.         )
     
115.         (and
     
116.           (<= (caar a) (caadr b) (caadr a))
     
117.           (<= (cadar a) (cadadr b) (cadadr a))
     
118.         )
     
119.         (and
     
120.           (<= (caar a) (caadr b) (caadr a))
     
121.           (<= (cadar a) (cadar b) (cadadr a))
     
122.         )
     
123.       )
     
124.       (list
     
125.         (apply 'mapcar (cons 'min (append a b)))
     
126.         (apply 'mapcar (cons 'max (append a b)))
     
127.       )
     
128.     )
     
129.   )
     
130.   (defun rectang (a b)
     
131.     (if (not (tblsearch "LAYER" "批量打印层"))
     
132.       (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(62 . 1) '(6 . "Continuous") (cons 2 "批量打印层")))
     
133.     )
     
134.     (entmake
     
135.       (list
     
136.         '(0 . "LWPOLYLINE")
     
137.         '(100 . "AcDbEntity")
     
138.         '(8 . "批量打印层")
     
139.         '(62 . 1)
     
140.         '(100 . "AcDbPolyline")
     
141.         '(90 . 4)
     
142.         '(70 . 1)
     
143.         (cons 10 a)
     
144.         (list 10 (car a) (cadr b))
     
145.         (cons 10 b)
     
146.         (list 10 (car b) (cadr a))
     
147.       )
     
148.     )
     
149.   )
     
150.   (if (setq ss (ssget))
     
151.     (cond
     
152.       ((> (sslength ss) 1)
     
153.         (setq n -1)
     
154.         (while (setq ent (ssname ss (setq n (1+ n))))
     
155.           (setq l (cons (box ent) l))
     
156.         )
     
157.         (setq l
     
158.           (vl-sort
     
159.             l
     
160.             '(lambda(a b)
     
161.                (if (equal (caar a) (caar b) 1e-3)
     
162.                  (if  (equal (cadar a) (cadar b) 1e-3)
     
163.                    (if (equal (caadr a) (caadr b) 1e-3)
     
164.                      (< (cadadr a) (cadadr b))
     
165.                      (< (caadr a) (caadr b))
     
166.                    )
     
167.                    (< (cadar a) (cadar b))
     
168.                  )
     
169.                  (< (caar a) (caar b))
     
170.                )
     
171.              )
     
172.           )
     
173.         )
     
174.         (setq a (car l) l (cdr l))
     
175.         (while l
     
176.           (setq l1 nil flag nil)
     
177.           (while l
     
178.             (setq  b (car l) l (cdr l))
     
179.             (if (setq c (intersect a b))
     
180.               (setq a c flag t)
     
181.               (setq l1 (cons b l1))
     
182.             )
     
183.           )
     
184.           (setq l (reverse l1))
     
185.           (if (not flag)
     
186.             (progn
     
187.               (rectang (car a) (cadr a))
     
188.               (setq a (car l)
     
189.                 l (cdr l)
     
190.               )
     
191.             )
     
192.           )
     
193.           (if (not l) (rectang (car a) (cadr a)))
     
194.         )
     
195.       )
     
196.       (T
     
197.         (setq a (box (ssname ss 0)))
     
198.         (rectang (car a) (cadr a))
     
199.       )
     
200.     )
     
201.   )
     
202.   (princ)
     
203. )

(defun c:mBox (/ A B BOX C ent FLAG INTERSECT L L1 N RECTANG SS)<br />   (defun box (e / b enx h j l lst n o obj p1 p2 p3 p4 r w xylst)<br />     (setq enx (entget e))<br />     (if (or (= "MTEXT" (cdr (assoc 0 enx))) (= "TEXT" (cdr (assoc 0 enx))))<br />       (progn<br />         (setq  l <br />           (cond<br />             ((= "TEXT" (cdr (assoc 0 enx)))<br />               (setq<br />                 b (cdr (assoc 10 enx))<br />                 r (cdr (assoc 50 enx))    <br />                 l (textbox enx)      <br />                 n (cdr (assoc 210 enx))    <br />               )<br />               (list<br />                 (list (caar l) (cadar l))    <br />                 (list (caadr l) (cadar l))<br />                 (list (caadr l) (cadadr l))<br />                 (list (caar l) (cadadr l))<br />               )<br />             )<br />             ((= "MTEXT" (cdr (assoc 0 enx)))<br />               (setq<br />                 n (cdr (assoc 210 enx))<br />                 b (trans (cdr (assoc 10 enx)) 0 n)<br />                 r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))<br />                 w (cdr (assoc 42 enx))<br />                 h (cdr (assoc 43 enx))<br />                 j (cdr (assoc 71 enx))<br />                 o (list<br />                     (cond<br />                       ((member j '(2 5 8)) (/ w -2.0))<br />                       ((member j '(3 6 9)) (- w))<br />                       (0.0)<br />                     )<br />                     (cond<br />                       ((member j '(1 2 3)) (- h))<br />                       ((member j '(4 5 6)) (/ h -2.0))<br />                       (0.0)<br />                       <br />                     )<br />                   )<br />               )<br />               (list<br />                 (list (car o) (cadr o))<br />                 (list (+ (car o) w) (cadr o))<br />                 (list (+ (car o) w) (+ (cadr o) h))<br />                 (list (car o) (+ (cadr o) h))<br />               )<br />             )<br />           )<br />         )<br />         (setq l <br />           (<br />             (lambda (m)<br />               (mapcar<br />                 '(lambda (p)<br />                    (mapcar '+ (mapcar '(lambda (r) (apply '+ (mapcar '* r p))) m) b)<br />                  )<br />                 l<br />               )<br />             )<br />             (list<br />               (list (cos r) (sin (- r)) 0.0)<br />               (list (sin r) (cos r) 0.0)<br />               '(0.0 0.0 1.0)<br />             )<br />           )<br />         )<br />         (setq<br />           xylst (apply 'mapcar (cons 'list (mapcar '(lambda (x) (trans x n 0)) l)))<br />           p1 (list (apply 'min (car xylst)) (apply 'min (cadr xylst))) <br />           p3 (list (apply 'max (car xylst)) (apply 'max (cadr xylst)))<br />         )<br />       )<br />       (progn<br />         (setq obj (vlax-ename->vla-object e))<br />         (vla-GetBoundingBox obj 'p1 'p3)<br />         (setq p1 (vlax-safearray->list p1)<br />           p3 (vlax-safearray->list p3)<br />           p2 (list (car p1) (cadr p3) (caddr p1))<br />           p4 (list (car p3) (cadr p1) (caddr p1))<br />         )<br />         (if  (= "SPLINE" (cdr (assoc 0 enx)))<br />           (progn<br />             (setq lst<br />               (mapcar '(lambda(a b)<br />                          (vlax-curve-getClosestPointToProjection e a b t)<br />                        )<br />                 (list p1 p2 p3 p4)<br />                 '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))<br />               )<br />             )<br />             (setq<br />               p1 (apply 'mapcar (cons 'min lst))<br />               p3 (apply 'mapcar (cons 'max lst))<br />             )<br />           )<br />         )<br />       )<br />     )<br />     (list p1 p3)<br />   )<br />   (defun intersect (a b)<br />     (if<br />       (or<br />         (and<br />           (<= (caar a) (caar b) (caadr a))<br />           (<= (cadar a) (cadar b) (cadadr a))<br />         )<br />         (and<br />           (<= (caar a) (caar b) (caadr a))<br />           (<= (cadar a) (cadadr b) (cadadr a))<br />         )<br />         (and<br />           (<= (caar a) (caadr b) (caadr a))<br />           (<= (cadar a) (cadadr b) (cadadr a))<br />         )<br />         (and<br />           (<= (caar a) (caadr b) (caadr a))<br />           (<= (cadar a) (cadar b) (cadadr a))<br />         )<br />       )<br />       (list<br />         (apply 'mapcar (cons 'min (append a b)))<br />         (apply 'mapcar (cons 'max (append a b)))<br />       )<br />     )<br />   )<br />   (defun rectang (a b)<br />     (if (not (tblsearch "LAYER" "批量打印层"))<br />       (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(62 . 1) '(6 . "Continuous") (cons 2 "批量打印层")))<br />     )<br />     (entmake<br />       (list<br />         '(0 . "LWPOLYLINE")<br />         '(100 . "AcDbEntity")<br />         '(8 . "批量打印层")<br />         '(62 . 1)<br />         '(100 . "AcDbPolyline")<br />         '(90 . 4)<br />         '(70 . 1)<br />         (cons 10 a)<br />         (list 10 (car a) (cadr b))<br />         (cons 10 b)<br />         (list 10 (car b) (cadr a))<br />       )<br />     )<br />   )<br />   (if (setq ss (ssget))<br />     (cond<br />       ((> (sslength ss) 1)<br />         (setq n -1)<br />         (while (setq ent (ssname ss (setq n (1+ n))))<br />           (setq l (cons (box ent) l))<br />         )<br />         (setq l<br />           (vl-sort<br />             l<br />             '(lambda(a b)<br />                (if (equal (caar a) (caar b) 1e-3)<br />                  (if  (equal (cadar a) (cadar b) 1e-3)<br />                    (if (equal (caadr a) (caadr b) 1e-3)<br />                      (< (cadadr a) (cadadr b))<br />                      (< (caadr a) (caadr b))<br />                    )<br />                    (< (cadar a) (cadar b))<br />                  )<br />                  (< (caar a) (caar b))<br />                )<br />              )<br />           )<br />         )<br />         (setq a (car l) l (cdr l))<br />         (while l<br />           (setq l1 nil flag nil)<br />           (while l<br />             (setq  b (car l) l (cdr l))<br />             (if (setq c (intersect a b))<br />               (setq a c flag t)<br />               (setq l1 (cons b l1))<br />             )<br />           )<br />           (setq l (reverse l1))<br />           (if (not flag)<br />             (progn<br />               (rectang (car a) (cadr a))<br />               (setq a (car l)<br />                 l (cdr l)<br />               )<br />             )<br />           )<br />           (if (not l) (rectang (car a) (cadr a)))<br />         )<br />       )<br />       (T<br />         (setq a (box (ssname ss 0)))<br />         (rectang (car a) (cadr a))<br />       )<br />     )<br />   )<br />   (princ)<br /> )

vlisp2012

THX A LOT!!!!!!!!!

479274135

感谢分享.....