提料程序---源码分享

雨的节奏

2. (defun c:chc (/ os ss s1 cds pt1 pt2 pt3 pt4 ptx1 ptx2 ptx3 ptx4 ptx5 ptx6 ptx7 ptx8 ptx9 ptx10 ptx11 ptx12 ptx13 ptx15 ptx16 py1 py2 py3 py4 py5 py6 th thlist en vlen wz pty1 pty2 en2 kuandu gaodu mianji mianjihe en1x boen xuhao interszj cd)
   
3. (setvar "cmdecho" 0)
   
4. (setq os (getvar "osmode"))
   
5. (setvar "osmode" 0)
   
6. ;设置完毕，开始绘制表格
   
7.   (setq ss (ssget '((0 . "*TEXT"))))
   
8.   (setq sl (sslength ss))
   
9.   (setq pt1 (getpoint "\n指定表格角点"))
   
10.   (setq pt4 (polar pt1 0 1400))
    
11.   (setq hh (+ (* sl 100) 400))
    
12.   (setq pt2 (polar pt1 (* pi 1.5) hh))
    
13.   (setq pt3 (polar pt2 0 1400))
    
14.   (command "pline" pt1 pt2 pt3 pt4 "")
    
15.   (command "line" pt1 pt4 "")
    
16.   (setq en1 (entlast))
    
17.   (command "array" en1 "" "r" (+ sl 4) 1 -100)
    
18.   ;以下绘制表头
    
19.   (command "._undo" "begin")
    
20.   (setq inters1 (list (+ 700 (car pt1)) (- (cadr pt1) 50)))   
    
21.   (command "text" "m" inters1 55 0 "石材尺寸清单")
    
22.   (setq inters2 (list (+ 200 (car pt1)) (- (cadr pt1) 150)))
    
23.   (command "text" "m" inters2 40 0 "石材种类")
    
24.   (setq pty1 (list (+ 400 (car pt1)) (- (cadr pt1) 200)))
    
25.   (setq pty2 (list (+ 400 (car pt1)) (- (cadr pt1) 100)))
    
26.   (command "line" pty1 pty2 "")
    
27.   (setq inters3 (polar inters2 0 800))
    
28.   (command "text" "m" inters3 40 0 "厚度")
    
29.   (setq ptx3 (polar pty1 0 500))
    
30.   (setq ptx4 (polar pty2 0 500))
    
31.   (setq pty3 (polar ptx3 0 250))
    
32.   (setq pty4 (polar ptx4 0 250))
    
33.   (command "line" ptx3 ptx4 "" "line" pty3 pty4 "")
    
34.   (setq ptx5 (polar pt1 (* pi 1.5) 250))
    
35.   (setq ptx6 (polar ptx5 0 60))
    
36.   (command "text" "m" ptx6 40 0 "序号")
    
37.   (setq ptx7 (polar ptx6 0 200))
    
38.   (command "text" "m" ptx7 40 0 "产品编号")
    
39.   (setq ptx8 (polar ptx7 0 250))
    
40.   (command "text" "m" ptx8 40 0 "宽度")
    
41.   (setq ptx9 (polar ptx8 0 250))
    
42.   (command "text" "m" ptx9 40 0 "高度")
    
43.   (setq ptx10 (polar ptx9 0 250))
    
44.   (command "text" "m" ptx10 40 0 "面积")
    
45.   (setq ptx11 (polar ptx10 0 250))
    
46.   (command "text" "m" ptx11 40 0 "备注")
    
47.   ;以下绘制表尾
    
48.   (setq interszj (list (+ 450 (car pt2)) (+ 50 (cadr pt2))))
    
49.   (command "text" "m" interszj 45 0 "总计")
    
50.   (setq ptx12 (polar pt2 0 900))
    
51.   (setq ptx13 (polar ptx12 (* pi 0.5) 100))
    
52.   (command "line" ptx12 ptx13 "")
    
53.   (setq ptx15 (polar ptx12 0 250))
    
54.   (setq ptx16 (polar ptx15 (* pi 0.5) 100))
    
55.   (command "line" ptx15 ptx16 "")
    
56.   ;绘制竖线
    
57.   (setq py1 (list (+ 120 (car pt1)) (- (cadr pt1) 200)))
    
58.   (setq py2 (list (+ 120 (car pt2)) (+ 100 (cadr pt2))))
    
59.   (command "line" py1 py2 "")
    
60.   (setq en2 (entlast))
    
61.   (setq py3 (polar py1 0 280) py4 (polar py3 0 250) py5 (polar py4 0 250) py6 (polar py5 0 250))
    
62.   (command "copy" en2 "" "m" py1 py3 py4 py5 py6 "")
    
63. 
    
64.   ;绘制表头表尾结束**************
    
65. 
    
66.   (setq thlist (ssget-cons ss))
    
67.   (setq th 0 xuhao 1 jiange 100 mianjihe 0)
    
68.   (repeat (length thlist)
    
69.   (setq en (nth th thlist))
    
70.   (setq vlen (Vlax-Ename->Vla-Object en))
    
71.   (setq wz (vla-get-TextString vlen))
    
72.   (setq cd (cdr (assoc 10 (entget en))))
    
73.   (setq cds (cdr (assoc 11 (entget en))))
    
74.   (setvar "cecolor" "6")
    
75.   (setq en1x (entlast))
    
76.   (command "boundary" cd "")
    
77.   (setq boen (entlast))
    
78.   (if (/= (equal boen en1x) nil)
    
79.       (progn (command "boundary" cds "")
    
80.              (setq boen (entlast))
    
81.        )
    
82.    )
    
83. 
    
84.   (if (= (equal boen en1x) nil)
    
85.   (progn
    
86.   (Min_Max)
    
87.   (setq gaodu (- maxy0 miny0) kuandu (- maxx0 minx0))
    
88.   (command "erase" boen "")
    
89.   (setq mianji (/ (* kuandu gaodu) 1000000))        
    
90.   (setq mianjihe (+ mianjihe mianji))
    
91.   (setq kuandu (rtos kuandu 2 0) gaodu (rtos gaodu 2 0) mianji (rtos mianji 2 2))
    
92.   (command "text" "m" (list (car ptx8) (- (cadr ptx8) jiange)) 35 0 kuandu)
    
93.   (command "text" "m" (list (car ptx9) (- (cadr ptx9) jiange)) 35 0 gaodu)
    
94.   (command "text" "m" (list (car ptx10) (- (cadr ptx10) jiange)) 35 0 mianji)
    
95.   )
    
96.   )
    
97.   (command "text" "m" (list (car ptx6) (- (cadr ptx6) jiange)) 35 0 (rtos xuhao 2 0))
    
98.   (command "text" "m" (list (car ptx7) (- (cadr ptx7) jiange)) 35 0 wz)
    
99.   (setq jiange (+ jiange 100))
    
100.   (setq xuhao (1+ xuhao))
     
101.   (setq th (1+ th))
     
102.   )
     
103.   (setq mianjihe (rtos mianjihe 2 2))
     
104.   (command "text" "m" (list (- (car pt3) 375) (+ 50 (cadr pt3))) 35 0 mianjihe)
     
105.   (setq ssbg (ssget "w" pt1 pt3))
     
106.   ;*****程序完成，恢复各项设置
     
107.   (setvar "osmode" os)
     
108.   (setvar "cecolor" "1")
     
109.   (command "scale" ssbg "" pt1 "r" pt1 pt3 pause)
     
110.   (command "._undo" "end")
     
111.   (princ "\n操作完成!!")
     
112.   (prin1)
     
113. )
     
114. (prompt "*****************提取石材料单尺寸程序，命令CHC****程序对图纸要求很高，只做交流，不对一切因使用本程序造成的后果负责***")
     
115. (prin1)
     
116. 
     
117. 
     
118. 
     
119. ;******选择集转换为列表并从小到大排列的子程序****
     
120. (defun ssget-cons (ss / k en1 thlist)
     
121.   (setq thlist ())
     
122.   (setq k 0)
     
123.   (repeat (sslength ss)
     
124.            (setq en1 (ssname ss k))
     
125.            (setq thlist (cons en1 thlist))
     
126.            (setq k (1+ k))
     
127.    )
     
128.    (setq thlist (vl-sort thlist (function (lambda (x1 x2) (< (atoi (texts X1)) (atoi (texts X2)))))))
     
129. )
     
130. ;提取出字符串中的数字
     
131. (defun texts (en / )
     
132.   (setq regex (vlax-create-object "Vbscript.RegExp"))
     
133.   (vlax-put-property regex "IgnoreCase" 1)
     
134.   (vlax-put-property regex "Global" 1)
     
135.   (setq en1 (vlax-ename->vla-object en))
     
136.   (setq enz (vla-get-TextString en1))
     
137.   (vlax-put-property regex "Pattern" "[^0-9]")
     
138.   (setq en1 (vlax-invoke-method  regex "Replace" enz ""))
     
139. )
     
140.            
     
141. 
     
142.     ;;;子程序，求选集是大外形坐标
     
143.     (defun Min_Max()
     
144.     (setq minx0 10e6 miny0 10e6 maxx0 -10e6 maxy0 -10e6)
     
145.     (vla-getboundingbox(vlax-ename->vla-object boen) 'minp 'maxp)
     
146.     (setq minp (vlax-safearray->list minp)
     
147.            maxp (vlax-safearray->list maxp))
     
148.     (setq minx (car minp)
     
149.            maxx (car maxp)
     
150.            miny (cadr minp)
     
151.            maxy (cadr maxp))
     
152.     (if (> minx0 minx) (setq minx0 minx))
     
153.     (if (> miny0 miny) (setq miny0 miny))
     
154.     (if (< maxx0 maxx) (setq maxx0 maxx))
     
155.     (if (< maxy0 maxy) (setq maxy0 maxy))
     
156.     )
     
157. (prin1)
     
158. 
     
159. 
     
160. 
     
161. 
     
162. 
     
163. 
     
164. 
     
165. 
     
166. 
     
167. 
     
168. 
     
169. 
     
170. 
     
171. 
     
172. 
     
173. 
     

(defun c:chc (/ os ss s1 cds pt1 pt2 pt3 pt4 ptx1 ptx2 ptx3 ptx4 ptx5 ptx6 ptx7 ptx8 ptx9 ptx10 ptx11 ptx12 ptx13 ptx15 ptx16 py1 py2 py3 py4 py5 py6 th thlist en vlen wz pty1 pty2 en2 kuandu gaodu mianji mianjihe en1x boen xuhao interszj cd)<br /> (setvar "cmdecho" 0)<br /> (setq os (getvar "osmode"))<br /> (setvar "osmode" 0)<br /> ;设置完毕，开始绘制表格<br />   (setq ss (ssget '((0 . "*TEXT"))))<br />   (setq sl (sslength ss))<br />   (setq pt1 (getpoint "\n指定表格角点"))<br />   (setq pt4 (polar pt1 0 1400))<br />   (setq hh (+ (* sl 100) 400))<br />   (setq pt2 (polar pt1 (* pi 1.5) hh))<br />   (setq pt3 (polar pt2 0 1400))<br />   (command "pline" pt1 pt2 pt3 pt4 "")<br />   (command "line" pt1 pt4 "")<br />   (setq en1 (entlast))<br />   (command "array" en1 "" "r" (+ sl 4) 1 -100)<br />   ;以下绘制表头<br />   (command "._undo" "begin")<br />   (setq inters1 (list (+ 700 (car pt1)) (- (cadr pt1) 50)))   <br />   (command "text" "m" inters1 55 0 "石材尺寸清单")<br />   (setq inters2 (list (+ 200 (car pt1)) (- (cadr pt1) 150)))<br />   (command "text" "m" inters2 40 0 "石材种类")<br />   (setq pty1 (list (+ 400 (car pt1)) (- (cadr pt1) 200)))<br />   (setq pty2 (list (+ 400 (car pt1)) (- (cadr pt1) 100)))<br />   (command "line" pty1 pty2 "")<br />   (setq inters3 (polar inters2 0 800))<br />   (command "text" "m" inters3 40 0 "厚度")<br />   (setq ptx3 (polar pty1 0 500))<br />   (setq ptx4 (polar pty2 0 500))<br />   (setq pty3 (polar ptx3 0 250))<br />   (setq pty4 (polar ptx4 0 250))<br />   (command "line" ptx3 ptx4 "" "line" pty3 pty4 "")<br />   (setq ptx5 (polar pt1 (* pi 1.5) 250))<br />   (setq ptx6 (polar ptx5 0 60))<br />   (command "text" "m" ptx6 40 0 "序号")<br />   (setq ptx7 (polar ptx6 0 200))<br />   (command "text" "m" ptx7 40 0 "产品编号")<br />   (setq ptx8 (polar ptx7 0 250))<br />   (command "text" "m" ptx8 40 0 "宽度")<br />   (setq ptx9 (polar ptx8 0 250))<br />   (command "text" "m" ptx9 40 0 "高度")<br />   (setq ptx10 (polar ptx9 0 250))<br />   (command "text" "m" ptx10 40 0 "面积")<br />   (setq ptx11 (polar ptx10 0 250))<br />   (command "text" "m" ptx11 40 0 "备注")<br />   ;以下绘制表尾<br />   (setq interszj (list (+ 450 (car pt2)) (+ 50 (cadr pt2))))<br />   (command "text" "m" interszj 45 0 "总计")<br />   (setq ptx12 (polar pt2 0 900))<br />   (setq ptx13 (polar ptx12 (* pi 0.5) 100))<br />   (command "line" ptx12 ptx13 "")<br />   (setq ptx15 (polar ptx12 0 250))<br />   (setq ptx16 (polar ptx15 (* pi 0.5) 100))<br />   (command "line" ptx15 ptx16 "")<br />   ;绘制竖线<br />   (setq py1 (list (+ 120 (car pt1)) (- (cadr pt1) 200)))<br />   (setq py2 (list (+ 120 (car pt2)) (+ 100 (cadr pt2))))<br />   (command "line" py1 py2 "")<br />   (setq en2 (entlast))<br />   (setq py3 (polar py1 0 280) py4 (polar py3 0 250) py5 (polar py4 0 250) py6 (polar py5 0 250))<br />   (command "copy" en2 "" "m" py1 py3 py4 py5 py6 "")<br /> <br />   ;绘制表头表尾结束**************<br /> <br />   (setq thlist (ssget-cons ss))<br />   (setq th 0 xuhao 1 jiange 100 mianjihe 0)<br />   (repeat (length thlist)<br />   (setq en (nth th thlist))<br />   (setq vlen (Vlax-Ename->Vla-Object en))<br />   (setq wz (vla-get-TextString vlen))<br />   (setq cd (cdr (assoc 10 (entget en))))<br />   (setq cds (cdr (assoc 11 (entget en)))) <br />   (setvar "cecolor" "6")<br />   (setq en1x (entlast))<br />   (command "boundary" cd "")<br />   (setq boen (entlast))<br />   (if (/= (equal boen en1x) nil) <br />       (progn (command "boundary" cds "")<br />              (setq boen (entlast))<br />        )<br />    )<br /> <br />   (if (= (equal boen en1x) nil)<br />   (progn<br />   (Min_Max)<br />   (setq gaodu (- maxy0 miny0) kuandu (- maxx0 minx0))<br />   (command "erase" boen "")<br />   (setq mianji (/ (* kuandu gaodu) 1000000))        <br />   (setq mianjihe (+ mianjihe mianji))<br />   (setq kuandu (rtos kuandu 2 0) gaodu (rtos gaodu 2 0) mianji (rtos mianji 2 2))<br />   (command "text" "m" (list (car ptx8) (- (cadr ptx8) jiange)) 35 0 kuandu)<br />   (command "text" "m" (list (car ptx9) (- (cadr ptx9) jiange)) 35 0 gaodu)<br />   (command "text" "m" (list (car ptx10) (- (cadr ptx10) jiange)) 35 0 mianji)<br />   )<br />   )<br />   (command "text" "m" (list (car ptx6) (- (cadr ptx6) jiange)) 35 0 (rtos xuhao 2 0))<br />   (command "text" "m" (list (car ptx7) (- (cadr ptx7) jiange)) 35 0 wz)<br />   (setq jiange (+ jiange 100))<br />   (setq xuhao (1+ xuhao))<br />   (setq th (1+ th))<br />   )<br />   (setq mianjihe (rtos mianjihe 2 2))<br />   (command "text" "m" (list (- (car pt3) 375) (+ 50 (cadr pt3))) 35 0 mianjihe)<br />   (setq ssbg (ssget "w" pt1 pt3))<br />   ;*****程序完成，恢复各项设置<br />   (setvar "osmode" os)<br />   (setvar "cecolor" "1")<br />   (command "scale" ssbg "" pt1 "r" pt1 pt3 pause)<br />   (command "._undo" "end")<br />   (princ "\n操作完成!!")<br />   (prin1)<br /> )<br /> (prompt "*****************提取石材料单尺寸程序，命令CHC****程序对图纸要求很高，只做交流，不对一切因使用本程序造成的后果负责***")<br /> (prin1)<br /> <br /> <br /> <br /> ;******选择集转换为列表并从小到大排列的子程序****<br /> (defun ssget-cons (ss / k en1 thlist)<br />   (setq thlist ())<br />   (setq k 0)<br />   (repeat (sslength ss)<br />            (setq en1 (ssname ss k))<br />            (setq thlist (cons en1 thlist))<br />            (setq k (1+ k))<br />    )<br />    (setq thlist (vl-sort thlist (function (lambda (x1 x2) (< (atoi (texts X1)) (atoi (texts X2)))))))<br /> )<br /> ;提取出字符串中的数字<br /> (defun texts (en / )<br />   (setq regex (vlax-create-object "Vbscript.RegExp"))<br />   (vlax-put-property regex "IgnoreCase" 1)<br />   (vlax-put-property regex "Global" 1)<br />   (setq en1 (vlax-ename->vla-object en))<br />   (setq enz (vla-get-TextString en1))<br />   (vlax-put-property regex "Pattern" "[^0-9]")<br />   (setq en1 (vlax-invoke-method  regex "Replace" enz ""))<br /> )<br />            <br /> <br />     ;;;子程序，求选集是大外形坐标<br />     (defun Min_Max()<br />     (setq minx0 10e6 miny0 10e6 maxx0 -10e6 maxy0 -10e6)<br />     (vla-getboundingbox(vlax-ename->vla-object boen) 'minp 'maxp)<br />     (setq minp (vlax-safearray->list minp)<br />            maxp (vlax-safearray->list maxp))<br />     (setq minx (car minp)<br />            maxx (car maxp)<br />            miny (cadr minp)<br />            maxy (cadr maxp))<br />     (if (> minx0 minx) (setq minx0 minx))<br />     (if (> miny0 miny) (setq miny0 miny))<br />     (if (< maxx0 maxx) (setq maxx0 maxx))<br />     (if (< maxy0 maxy) (setq maxy0 maxy))<br />     )<br /> (prin1)<br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br />

这个是很多年前写的、、、
水平很菜
有需要的朋友可以拿去随便改随便用

尘缘一生

程序面积计算不准确，另外，用了很多的COMMAND，速度慢，再者，对选择集排序方面，也是有点问题，那就是，对于文字选择集的，失效，再者，对于画完了表，再SCALE的方式，值得探讨，最好适合比例一次画成即可，本次没修改这部分。
我改写一下，看模样吧

• ;; 提料程序---源码分享
• (defun c:chc (/ e_lst ss s1 pt1 pt2 pt3 pt4 ptx1 ptx2 ptx3 ptx4 ptx5 ptx6 ptx7 ptx8 ptx9 ptx10 ptx11 ptx12 ptx13 ptx15 ptx16 py1 py2 th thlist en wz pty1 pty2
•                kuandu gaodu mianji mianjihe boen xuhao interszj e plis hh sl obj w h)
•   (setq e_lst (sysvar '("osmode" "cmdecho" "ORTHOMODE")))
•   (setvar "cmdecho" 0)
•   (setvar "OSMODE" 0)
•   (setvar "ORTHOMODE" 0)
•   (command "._undo" "begin")
•   ;设置完毕，开始绘制表格
•   (setq ss (ssget '((0 . "*TEXT"))))
•   (setq sl (sslength ss))
•   (setq pt1 (getpoint "\n 指定表格角点"))
•   (setq pt4 (polar pt1 0 1400))
•   (setq hh (+ (* sl 100) 400))
•   (setq pt2 (polar pt1 3pi2 hh))
•   (setq pt3 (polar pt2 0 1400))
•   (setq e (entlast))
•   (makelwpolyline (list pt1 pt2 pt3 pt4) 0 t)
•   (makeline pt1 pt4)
•   (command "array" (entlast) "" "r" (+ sl 4) 1 -100)
•   ;以下绘制表头
•   (setq inters1 (list (+ 700 (car pt1)) (- (cadr pt1) 50) 0))   
•   (slmkwz "出版尺寸" inters1 (/ 55 slbl) 0 nil "表格" nil nil "m")
•   (setq inters2 (list (+ 200 (car pt1)) (- (cadr pt1) 150) 0))
•   (slmkwz "板材编号" inters2 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq pty1 (list (+ 400 (car pt1)) (- (cadr pt1) 200)))
•   (setq pty2 (list (+ 400 (car pt1)) (- (cadr pt1) 100)))
•   (makeline pty1 pty2)
•   (setq inters3 (polar inters2 0 800))
•   (slmkwz "厚度" inters3 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx3 (polar pty1 0 500))
•   (setq ptx4 (polar pty2 0 500))
•   (setq pty3 (polar ptx3 0 250))
•   (setq pty4 (polar ptx4 0 250))
•   (makeline ptx3 ptx4)
•   (makeline pty3 pty4)
•   (setq ptx5 (polar pt1 3pi2 250))
•   (setq ptx6 (polar ptx5 0 60))
•   (slmkwz "序号" ptx6 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx7 (polar ptx6 0 200))
•   (slmkwz "产品编号" ptx7 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx8 (polar ptx7 0 250))
•   (slmkwz "宽度" ptx8 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx9 (polar ptx8 0 250))
•   (slmkwz "高度" ptx9 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx10 (polar ptx9 0 250))
•   (slmkwz "面积m2" ptx10 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx11 (polar ptx10 0 250))
•   (slmkwz "备注" ptx11 (/ 40 slbl) 0 nil "表格" nil nil "m")
•   ;以下绘制表尾
•   (setq interszj (list (+ 450 (car pt2)) (+ 50 (cadr pt2)) 0))
•   (slmkwz "总计" interszj (/ 45 slbl) 0 nil "表格" nil nil "m")
•   (setq ptx12 (polar pt2 0 900))
•   (setq ptx13 (polar ptx12 pi2 100))
•   (makeline ptx12 ptx13)
•   (setq ptx15 (polar ptx12 0 250))
•   (setq ptx16 (polar ptx15 pi2 100))
•   (makeline ptx15 ptx16)
•   ;绘制竖线
•   (setq py1 (list (+ 120 (car pt1)) (- (cadr pt1) 200)))
•   (setq py2 (list (+ 120 (car pt2)) (+ 100 (cadr pt2))))
•   (makeline py1 py2)
•   (setq py1 (polar py1 0 280))
•   (setq py2 (polar py2 0 280))
•   (makeline py1 py2)
•   (setq py1 (polar py1 0 250))
•   (setq py2 (polar py2 0 250))
•   (makeline py1 py2)
•   (setq py1 (polar py1 0 250))
•   (setq py2 (polar py2 0 250))
•   (makeline py1 py2)
•   (setq py1 (polar py1 0 250))
•   (setq py2 (polar py2 0 250))
•   (makeline py1 py2)
•   ;绘制表结束
•   
•   (setq thlist (ss-enlst ss)) ;;选择集转实体名表并排序
•   (setq xuhao 1 jiange 100 mianjihe 0)
•   (repeat (setq th (length thlist))
•     (setq en (nth (setq th (1- th)) thlist))
•     (setq wz (getstr en))
•     (command "boundary" "a" "o" "p" "" (e-mid en) "")  ;生成多段线
•     (setq boen (entlast))
•     (if boen
•       (progn
•         (setq plis (e-box4 boen t) obj (en2obj boen))
•         (setq w (* (distance (car plis) (cadddr plis)) (getvar "dimlfac")))
•         (setq h (* (distance (car plis) (cadr plis)) (getvar "dimlfac")))
•         (if (>= w h)
•           (progn
•             (setq kuandu h)
•             (setq gaodu w)
•           )
•           (progn
•             (setq kuandu w)
•             (setq gaodu h)
•           )
•         )
•         (if (vlax-property-available-p obj "area")
•           (setq mianji (* (getvar "dimlfac") (getvar "dimlfac") (vlax-get-property obj 'area) 0.000001))
•         )
•         (entdel boen)
•       )
•       (setq mianji 0.0 kuandu 0.0 gaodu 0.0)
•     )
•     (setq mianjihe (+ mianjihe mianji))
•     (setq mianji (rtos mianji 2 2) kuandu (rtos kuandu 2 0) gaodu (rtos gaodu 2 0))
•     (slmkwz kuandu (list (car ptx8) (- (cadr ptx8) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")  
•     (slmkwz gaodu (list (car ptx9) (- (cadr ptx9) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
•     (slmkwz mianji (list (car ptx10) (- (cadr ptx10) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
•     (slmkwz (rtos xuhao 2 0) (list (car ptx6) (- (cadr ptx6) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
•     (slmkwz wz (list (car ptx7) (- (cadr ptx7) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m") ;;编号
•     (setq jiange (+ jiange 100))
•     (setq xuhao (1+ xuhao))
•   )
•   (slmkwz (rtos mianjihe 2 2) (list (- (car pt3) 375) (+ 50 (cadr pt3)) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
•   ;*****程序完成，恢复各项设置
•   (command "scale" (last_ent e) "" pt1 "r" pt1 pt3 pause)
•   (command "._undo" "end")
•   (mapcar 'eval e_lst)
• )
• (prompt "提取石材料单尺寸程序，命令CHC****程序对图纸要求很高，只做交流，不对一切因使用本程序造成的后果负责***")
• (prin1)
  

p-3-ianlcc

fan_zh 发表于 2019-7-24 13:48
我这个，可能更好用些，带合并数量并编号功能

您这个感觉很好用～
方便分享吗？

fan_zh

p-3-ianlcc 发表于 2020-6-1 15:58
您这个感觉很好用～
方便分享吗？

有需要可以定制，pm我吧

hn10183051

如果能把编号长宽相同统计数量就完美了

yoyoho

支持一下   谢谢分享!!!!!!

669423907

谢谢楼主分享好程序

fan_zh

我这个，可能更好用些，带合并数量并编号功能

tranney

东西非常好，现在也能用也好用

renyonghua2014

看看学习学习，谢谢分享！

烟盒迷唇

可以改用entmake,速度会快一点

写不完的日记

http://bbs.mjtd.com/thread-179900-1-1.html这个里面有思路可以看看你！

写不完的日记

fan_zh 发表于 2019-7-24 13:48
我这个，可能更好用些，带合并数量并编号功能

你这个源码呢