求程序，根据图纸示例，框选上面光缆程式，批量生成下方统计表。

网络工作者

求助，请过路的大师看看这个可以做成批量框选汇总吗？请赐教源码，十分感谢！

根据图纸示例，框选上面光缆程式，批量生成下方统计表。







提供一个半成品程序，过路的大神看到后麻烦指导修改下，成品结果是错的。

2. [code=lisp](defun c:CBLSTATS ()
   
3.     ; 初始化计数列表
   
4.     (setq l '())
   
5. 
   
6.     ; 选择光缆程式文本
   
7.     (princ "\n选择光缆程式文本: ")
   
8.     (setq s (ssget))
   
9.     (if (null s)
   
10.         (progn
    
11.             (princ "\n未选择对象!")
    
12.             (return)
    
13.         )
    
14.     )
    
15. 
    
16.     ; 统计光缆程式数量
    
17.     (setq n (sslength s)
    
18.           i 0
    
19.     )
    
20.     (while (< i n)
    
21.         (setq e (ssname s i)
    
22.               d (entget e)
    
23.               t (cdr (assoc 0 d))
    
24.         )
    
25.         ; 只处理TEXT和MTEXT对象
    
26.         (if (or (= t "TEXT") (= t "MTEXT"))
    
27.             (progn
    
28.                 (setq c (cdr (assoc 1 d)))
    
29.                 (if (not (null c))
    
30.                     (progn
    
31.                         ; 清理空格
    
32.                         (setq cl c)
    
33.                         (while (= (substr cl 1 1) " ")
    
34.                             (setq cl (substr cl 2 (strlen cl)))
    
35.                         )
    
36.                         (while (= (substr cl (strlen cl) 1) " ")
    
37.                             (setq cl (substr cl 1 (- (strlen cl) 1)))
    
38.                         )
    
39.                         
    
40.                         ; 检查是否已存在该程式
    
41.                         (setq f 0)
    
42.                         (setq j 0)
    
43.                         (while (< j (length l))
    
44.                             (setq x (nth j l))
    
45.                             (if (= (car x) cl)
    
46.                                 (progn
    
47.                                     ; 更新计数
    
48.                                     (setq newitem (list (car x) (+ (cadr x) 1)))
    
49.                                     (setq l (subst newitem x l))
    
50.                                     (setq f 1)
    
51.                                 )
    
52.                             )
    
53.                             (setq j (+ j 1))
    
54.                         )
    
55.                         ; 如果是新程式则添加
    
56.                         (if (= f 0)
    
57.                             (setq l (cons (list cl 1) l))
    
58.                         )
    
59.                     )
    
60.                 )
    
61.             )
    
62.         )
    
63.         (setq i (+ i 1))
    
64.     )
    
65. 
    
66.     ; 无数据则退出
    
67.     (if (null l)
    
68.         (progn
    
69.             (princ "\n无有效数据!")
    
70.             (return)
    
71.         )
    
72.     )
    
73. 
    
74.     ; 获取插入点
    
75.     (princ "\n指定表格插入点: ")
    
76.     (setq p (getpoint))
    
77.     (if (null p)
    
78.         (setq p (list 0 0 0))
    
79.     )
    
80. 
    
81.     ; 表格参数
    
82.     (setq h 2.5
    
83.           w1 15
    
84.           w2 15
    
85.           w3 10
    
86.           rh 3
    
87.           y (cadr p)
    
88.           tl (car p)
    
89.           tr (+ (car p) w1 w2 w3)
    
90.     )
    
91. 
    
92.     ; 绘制标题
    
93.     (command "TEXT" (list (/ (+ tl tr) 2) y 0) h 0 "光缆程式统计" "")
    
94.     (setq y (- y (* rh 2)))
    
95. 
    
96.     ; 绘制表头
    
97.     (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 "程式" "")
    
98.     (command "TEXT" (list (+ tl w1 (/ w2 2)) y 0) h 0 "分类" "")
    
99.     (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 "数量" "")
    
100.    
     
101.     ; 表头线条
     
102.     (setq sy (+ y rh 1)
     
103.           ey (- y rh 0.5)
     
104.     )
     
105.     (command "LINE" (list tl sy) (list tr sy) "")
     
106.     (command "LINE" (list tl ey) (list tr ey) "")
     
107.     (command "LINE" (list (+ tl w1) sy) (list (+ tl w1) ey) "")
     
108.     (command "LINE" (list (+ tl w1 w2) sy) (list (+ tl w1 w2) ey) "")
     
109.     (setq y ey)
     
110. 
     
111.     ; 分类项
     
112.     (setq items '("拆管道" "拆架空" "拆引上" "管道" "架空" "引上" "余" "合计"))
     
113. 
     
114.     ; 填充表格内容
     
115.     (setq k 0)
     
116.     (while (< k (length l))
     
117.         (setq x (nth k l)
     
118.               cn (car x)
     
119.               cq (cadr x)
     
120.               total 0
     
121.               sy y
     
122.         )
     
123.         (setq m 0)
     
124.         (while (< m (length items))
     
125.             (setq it (nth m items)
     
126.                   y (- y rh)
     
127.             )
     
128.             ; 填写光缆程式
     
129.             (if (= m 0)
     
130.                 (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 cn "")
     
131.                 (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 "" "")
     
132.             )
     
133.             ; 填写分类项
     
134.             (command "TEXT" (list (+ tl w1 (/ w2 2)) y 0) h 0 it "")
     
135.             ; 填写数量
     
136.             (if (= it "合计")
     
137.                 (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 (rtos total 2 1) "")
     
138.                 (progn
     
139.                     (setq val (* cq 40.5))
     
140.                     (setq total (+ total val))
     
141.                     (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 (rtos val 2 1) "")
     
142.                 )
     
143.             )
     
144.             (setq m (+ m 1))
     
145.         )
     
146.         ; 绘制子表格线条
     
147.         (setq ey y)
     
148.         (command "LINE" (list tl sy) (list tl ey) "")
     
149.         (command "LINE" (list tr sy) (list tr ey) "")
     
150.         (command "LINE" (list (+ tl w1) sy) (list (+ tl w1) ey) "")
     
151.         (command "LINE" (list (+ tl w1 w2) sy) (list (+ tl w1 w2) ey) "")
     
152.         (command "LINE" (list tl ey) (list tr ey) "")
     
153.         (setq y (- y rh)
     
154.               k (+ k 1)
     
155.         )
     
156.     )
     
157. 
     
158.     ; 绘制外边框
     
159.     (command "LINE" (list tl (cadr p)) (list tl y) "")
     
160.     (command "LINE" (list tr (cadr p)) (list tr y) "")
     
161.     (command "LINE" (list tl y) (list tr y) "")
     
162. 
     
163.     (princ "\n统计完成!")
     
164.     (princ)
     
165. )
     

[code=lisp](defun c:CBLSTATS ()<br />     ; 初始化计数列表<br />     (setq l '())<br /> <br />     ; 选择光缆程式文本<br />     (princ "\n选择光缆程式文本: ")<br />     (setq s (ssget))<br />     (if (null s)<br />         (progn<br />             (princ "\n未选择对象!")<br />             (return)<br />         )<br />     )<br /> <br />     ; 统计光缆程式数量<br />     (setq n (sslength s)<br />           i 0<br />     )<br />     (while (< i n)<br />         (setq e (ssname s i)<br />               d (entget e)<br />               t (cdr (assoc 0 d))<br />         )<br />         ; 只处理TEXT和MTEXT对象<br />         (if (or (= t "TEXT") (= t "MTEXT"))<br />             (progn<br />                 (setq c (cdr (assoc 1 d)))<br />                 (if (not (null c))<br />                     (progn<br />                         ; 清理空格<br />                         (setq cl c)<br />                         (while (= (substr cl 1 1) " ")<br />                             (setq cl (substr cl 2 (strlen cl)))<br />                         )<br />                         (while (= (substr cl (strlen cl) 1) " ")<br />                             (setq cl (substr cl 1 (- (strlen cl) 1)))<br />                         )<br />                         <br />                         ; 检查是否已存在该程式<br />                         (setq f 0)<br />                         (setq j 0)<br />                         (while (< j (length l))<br />                             (setq x (nth j l))<br />                             (if (= (car x) cl)<br />                                 (progn<br />                                     ; 更新计数<br />                                     (setq newitem (list (car x) (+ (cadr x) 1)))<br />                                     (setq l (subst newitem x l))<br />                                     (setq f 1)<br />                                 )<br />                             )<br />                             (setq j (+ j 1))<br />                         )<br />                         ; 如果是新程式则添加<br />                         (if (= f 0)<br />                             (setq l (cons (list cl 1) l))<br />                         )<br />                     )<br />                 )<br />             )<br />         )<br />         (setq i (+ i 1))<br />     )<br /> <br />     ; 无数据则退出<br />     (if (null l)<br />         (progn<br />             (princ "\n无有效数据!")<br />             (return)<br />         )<br />     )<br /> <br />     ; 获取插入点<br />     (princ "\n指定表格插入点: ")<br />     (setq p (getpoint))<br />     (if (null p)<br />         (setq p (list 0 0 0))<br />     )<br /> <br />     ; 表格参数<br />     (setq h 2.5<br />           w1 15<br />           w2 15<br />           w3 10<br />           rh 3<br />           y (cadr p)<br />           tl (car p)<br />           tr (+ (car p) w1 w2 w3)<br />     )<br /> <br />     ; 绘制标题<br />     (command "TEXT" (list (/ (+ tl tr) 2) y 0) h 0 "光缆程式统计" "")<br />     (setq y (- y (* rh 2)))<br /> <br />     ; 绘制表头<br />     (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 "程式" "")<br />     (command "TEXT" (list (+ tl w1 (/ w2 2)) y 0) h 0 "分类" "")<br />     (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 "数量" "")<br />     <br />     ; 表头线条<br />     (setq sy (+ y rh 1)<br />           ey (- y rh 0.5)<br />     )<br />     (command "LINE" (list tl sy) (list tr sy) "")<br />     (command "LINE" (list tl ey) (list tr ey) "")<br />     (command "LINE" (list (+ tl w1) sy) (list (+ tl w1) ey) "")<br />     (command "LINE" (list (+ tl w1 w2) sy) (list (+ tl w1 w2) ey) "")<br />     (setq y ey)<br /> <br />     ; 分类项<br />     (setq items '("拆管道" "拆架空" "拆引上" "管道" "架空" "引上" "余" "合计"))<br /> <br />     ; 填充表格内容<br />     (setq k 0)<br />     (while (< k (length l))<br />         (setq x (nth k l)<br />               cn (car x)<br />               cq (cadr x)<br />               total 0<br />               sy y<br />         )<br />         (setq m 0)<br />         (while (< m (length items))<br />             (setq it (nth m items)<br />                   y (- y rh)<br />             )<br />             ; 填写光缆程式<br />             (if (= m 0)<br />                 (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 cn "")<br />                 (command "TEXT" (list (+ tl (/ w1 2)) y 0) h 0 "" "")<br />             )<br />             ; 填写分类项<br />             (command "TEXT" (list (+ tl w1 (/ w2 2)) y 0) h 0 it "")<br />             ; 填写数量<br />             (if (= it "合计")<br />                 (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 (rtos total 2 1) "")<br />                 (progn<br />                     (setq val (* cq 40.5))<br />                     (setq total (+ total val))<br />                     (command "TEXT" (list (+ tl w1 w2 (/ w3 2)) y 0) h 0 (rtos val 2 1) "")<br />                 )<br />             )<br />             (setq m (+ m 1))<br />         )<br />         ; 绘制子表格线条<br />         (setq ey y)<br />         (command "LINE" (list tl sy) (list tl ey) "")<br />         (command "LINE" (list tr sy) (list tr ey) "")<br />         (command "LINE" (list (+ tl w1) sy) (list (+ tl w1) ey) "")<br />         (command "LINE" (list (+ tl w1 w2) sy) (list (+ tl w1 w2) ey) "")<br />         (command "LINE" (list tl ey) (list tr ey) "")<br />         (setq y (- y rh)<br />               k (+ k 1)<br />         )<br />     )<br /> <br />     ; 绘制外边框<br />     (command "LINE" (list tl (cadr p)) (list tl y) "")<br />     (command "LINE" (list tr (cadr p)) (list tr y) "")<br />     (command "LINE" (list tl y) (list tr y) "")<br /> <br />     (princ "\n统计完成!")<br />     (princ)<br /> )<br />

GEGEYANG88

问题太强了！先坐好沙发，再等待结果！

lxl304712346

目前只是生成表格行列的线有问题。

飞雪神光

这一看就是捕捉没关 要么关捕捉 要么换成entmake

网络工作者

飞雪神光 发表于 2025-10-5 10:06
这一看就是捕捉没关 要么关捕捉 要么换成entmake

统计的数值也不正确，不知道问题出现在哪里了？

飞雪神光

网络工作者 发表于 2025-10-5 10:51
统计的数值也不正确，不知道问题出现在哪里了？

看了一下 有很多错误啊  逻辑也不通 还给 t 赋值 批量操作也没见数据分类和关联