圆孔分类统计程序请大神优化，外径相同的圆经常被分成2种统计

听见天晴

程序也是论坛找的，觉得很方便，但是用起来有几个小问题，希望有大神帮忙修改一下：

1.相同直径的圆经常会统计成不一样的（这是3D软件导出的2D图），希望同样外径的只有一种规格。
程序里面同心圆已经修改成只找外圆忽略内圆了，算一个沉头孔，这个不是BUG，需要保留。
2.块中的圆目前无法统计，如果能一起统计就更好了。
3.鼠标点击的位置是生成文字的左下角，希望改成左上角（不改变排列，还是直径小的在上面大的在下面）。

主要是第一点，其他点都可以用，只是希望能好，希望大神帮忙优化一下，谢谢，以下是目前程序的演示
源程序
测试的DWG

tempasdf

2. (defun c:K()
   
3.   (princ "\n选择要进行统计的圆对象")
   
4.   (setq ss (ssget (list (cons 0 "CIRCLE"))))
   
5.   
   
6.   ;; 获取用户输入的文字高度
   
7.   (setq text-height (getreal "\n请输入文字高度（默认3.0）
   
8. : "))
   
9.   (if (not text-height)
   
10.     (setq text-height 3.0)  ;; 如果未输入，使用默认值3.0
    
11.   )
    
12.   
    
13.   ;; 选择输出基点
    
14.   (setq pt (getpoint "\n选择输出基点:"))
    
15.   
    
16.   (setq si 0 tx 65 px (car pt) py (cadr pt) li '() lii 0)
    
17.   (setq os (getvar "osmode") om (getvar "cmdecho"))
    
18.   
    
19.   (command "cmdecho" 0 "osmode" 0)
    
20.   
    
21.   ;; 设置文字高度
    
22.   (setq circle-text-height text-height)  ;; 圆右上角字母高度
    
23.   (setq stats-text-height text-height)   ;; 统计文字高度
    
24.   
    
25.   ;; 设置模糊距离
    
26.   (setq fuzz 0.01) ;; 同心圆判断的模糊距离
    
27. 
    
28.   ;; 启动事务，以便一起撤销
    
29.   (command "UNDO" "Begin")
    
30. 
    
31.   ;; 筛选出最大圆
    
32.   (setq filtered-circles (filter-largest-circles ss fuzz))
    
33. 
    
34.   ;; 按圆半径对选择集进行排序
    
35.   (setq filtered-circles (BF-pickset-sortwithdxf filtered-circles 40 nil 0.1 nil))
    
36. 
    
37.   ;; 遍历筛选后的圆集合，生成字母
    
38.   (repeat (sslength filtered-circles)
    
39.     (setq cs (ssname filtered-circles si) ce (entget cs))
    
40.     (setq cp (cdr (assoc 10 ce))) ;; 获取圆心
    
41.     ;(setq cr (cdr (assoc 40 ce))) ;; 获取半径
    
42.     (setq cr (atof (rtos (* 1 (cdr (assoc 40 ce))) 2 2))) ;; 获取半径
    
43.     (if (setq lst (assoc cr li))
    
44.       (setq ct (nth 1 lst) li (subst (list cr ct (1+ (nth 2 lst))) lst li))
    
45.       (setq ct tx tx (1+ tx) li (cons (list cr ct 1) li))
    
46.     )
    
47. 
    
48.     ;; 圆右上角计算
    
49.     (setq cp1 (polar cp (/ pi 4) (* cr 1.2))) ;; 在圆外右上角，距离调整为1.2倍半径
    
50.     (setq cp1 (trans cp1 0 1)) ;; 转换坐标
    
51. 
    
52.     ;; 在右上角生成字母
    
53.     (command "_.text" cp1 circle-text-height 0 (chr ct))
    
54.     (command "_.chprop" "l" "" "p" "c" 5 "")
    
55.     (setq si (1+ si))
    
56.   )
    
57. 
    
58. ;; 输出统计文字
    
59.   (foreach l li
    
60.     (setq cp (list px (+ py (* lii (* stats-text-height 1.5))))) ;; 间距为统计文字高度的1.5倍
    
61.     (setq cr (nth 0 l) ct (nth 1 l) cn (nth 2 l))
    
62.     ;; 拼接文字格式为 "A-1 %%c5.5"
    
63.     (command "_.text" cp stats-text-height 0 (strcat (chr ct) "-" (itoa cn) "  %%c" (rtos (* cr 2) 2 1)))
    
64.     (command "_.chprop" "l" "" "p" "c" 255 "")
    
65.     (setq lii (1+ lii))
    
66.   )
    
67. 
    
68. 
    
69.   ;; 结束事务
    
70.   (command "UNDO" "End")
    
71. 
    
72.   ;; 恢复设置
    
73.   (setvar "osmode" 4159)
    
74.   (princ "\n统计完成!")
    
75.   (princ)
    
76. )
    
77. 
    
78. ;; 筛选同心圆，只保留半径最大的圆
    
79. (defun filter-largest-circles (ss fuzz / circles grouped result)
    
80.   (setq circles '()
    
81.         grouped '()
    
82.         result (ssadd))
    
83.   ;; 提取圆心和半径
    
84.   (repeat (sslength ss)
    
85.     (setq ent (entget (ssname ss 0)))
    
86.     (setq center (cdr (assoc 10 ent)))
    
87.     ;(setq radius (cdr (assoc 40 ent)))
    
88.     (setq radius (atof (rtos (* 1 (cdr (assoc 40 ent))) 2 2)))
    
89.     (setq circles (cons (list center radius (cdr (assoc 5 ent))) circles))
    
90.     (setq ss (ssdel (ssname ss 0) ss))
    
91.   )
    
92.   ;; 分组同心圆
    
93.   (foreach c1 circles
    
94.     (setq found nil)
    
95.     (foreach g grouped
    
96.       (if (and (not found)
    
97.                (< (distance (car c1) (car (car g))) fuzz)) ;; 判断是否同心
    
98.         (progn (setq g (cons c1 g)) (setq found t))
    
99.       )
    
100.     )
     
101.     (if (not found) (setq grouped (cons (list c1) grouped)))
     
102.   )
     
103.   ;; 选出每组中半径最大的圆
     
104.   (foreach g grouped
     
105.     (setq max-circle (car g))
     
106.     (foreach c g
     
107.       (if (> (cadr c) (cadr max-circle))
     
108.         (setq max-circle c)))
     
109.     ;; 添加最大圆到结果集
     
110.     (setq result (ssadd (handent (caddr max-circle)) result))
     
111.   )
     
112.   result
     
113. )
     
114. 
     
115. (defun BF-pickset-sortwithdxf (SE i INT FUZZ K / ENT INDEX LST NEWLST NEWSE TMP)
     
116.   (setq LST '() INDEX 0)
     
117.   (repeat (sslength SE)
     
118.     (setq ENT (entget (ssname SE INDEX))
     
119.           TMP (cdr (assoc i ENT)))
     
120.     (if (and INT
     
121.              (= (type INT) 'INT)
     
122.              (= (type TMP) 'list)
     
123.              (< INT (length TMP)))
     
124.       (setq TMP (nth INT TMP)))
     
125.     (setq LST (cons (list TMP (cdr (assoc 5 ENT))) LST))
     
126.     (setq INDEX (1+ INDEX))
     
127.   )
     
128.   (if (and FUZZ
     
129.            (or (= (type FUZZ) 'INT)
     
130.                (= (type FUZZ) 'REAL))
     
131.            (or (= (type TMP) 'INT)
     
132.                (= (type TMP) 'REAL)))
     
133.     (setq NEWLST
     
134.           (vl-sort LST
     
135.                    (function (lambda (E1 E2)
     
136.                                (< (+ (car E1) FUZZ) (car  E2))))))
     
137.     (setq NEWLST
     
138.           (vl-sort LST
     
139.                    (function (lambda (E1 E2)
     
140.                                (< (car E1) (car E2))))))
     
141.   )
     
142.   (if K
     
143.     (setq NEWLST (reverse NEWLST)))
     
144.   (setq NEWSE (ssadd))
     
145.   (foreach TMP NEWLST
     
146.     (setq NEWSE (ssadd (handent (cadr TMP)) NEWSE)))
     
147.   NEWSE
     
148. )
     
149. 
     
150. (prompt "\n 本程序可用圆孔统计；启动命令【K】")
     
151. (prin1)
     

(defun c:K()<br />   (princ "\n选择要进行统计的圆对象")<br />   (setq ss (ssget (list (cons 0 "CIRCLE"))))<br />   <br />   ;; 获取用户输入的文字高度<br />   (setq text-height (getreal "\n请输入文字高度（默认3.0）<br /> : "))<br />   (if (not text-height)<br />     (setq text-height 3.0)  ;; 如果未输入，使用默认值3.0<br />   )<br />   <br />   ;; 选择输出基点<br />   (setq pt (getpoint "\n选择输出基点:"))<br />   <br />   (setq si 0 tx 65 px (car pt) py (cadr pt) li '() lii 0)<br />   (setq os (getvar "osmode") om (getvar "cmdecho"))<br />   <br />   (command "cmdecho" 0 "osmode" 0)<br />   <br />   ;; 设置文字高度<br />   (setq circle-text-height text-height)  ;; 圆右上角字母高度<br />   (setq stats-text-height text-height)   ;; 统计文字高度<br />   <br />   ;; 设置模糊距离<br />   (setq fuzz 0.01) ;; 同心圆判断的模糊距离<br /> <br />   ;; 启动事务，以便一起撤销<br />   (command "UNDO" "Begin")<br /> <br />   ;; 筛选出最大圆<br />   (setq filtered-circles (filter-largest-circles ss fuzz))<br /> <br />   ;; 按圆半径对选择集进行排序<br />   (setq filtered-circles (BF-pickset-sortwithdxf filtered-circles 40 nil 0.1 nil))<br /> <br />   ;; 遍历筛选后的圆集合，生成字母<br />   (repeat (sslength filtered-circles)<br />     (setq cs (ssname filtered-circles si) ce (entget cs))<br />     (setq cp (cdr (assoc 10 ce))) ;; 获取圆心<br />     ;(setq cr (cdr (assoc 40 ce))) ;; 获取半径<br />     (setq cr (atof (rtos (* 1 (cdr (assoc 40 ce))) 2 2))) ;; 获取半径<br />     (if (setq lst (assoc cr li))<br />       (setq ct (nth 1 lst) li (subst (list cr ct (1+ (nth 2 lst))) lst li))<br />       (setq ct tx tx (1+ tx) li (cons (list cr ct 1) li))<br />     )<br /> <br />     ;; 圆右上角计算<br />     (setq cp1 (polar cp (/ pi 4) (* cr 1.2))) ;; 在圆外右上角，距离调整为1.2倍半径<br />     (setq cp1 (trans cp1 0 1)) ;; 转换坐标<br /> <br />     ;; 在右上角生成字母<br />     (command "_.text" cp1 circle-text-height 0 (chr ct))<br />     (command "_.chprop" "l" "" "p" "c" 5 "")<br />     (setq si (1+ si))<br />   )<br /> <br /> ;; 输出统计文字<br />   (foreach l li<br />     (setq cp (list px (+ py (* lii (* stats-text-height 1.5))))) ;; 间距为统计文字高度的1.5倍<br />     (setq cr (nth 0 l) ct (nth 1 l) cn (nth 2 l))<br />     ;; 拼接文字格式为 "A-1 %%c5.5"<br />     (command "_.text" cp stats-text-height 0 (strcat (chr ct) "-" (itoa cn) "  %%c" (rtos (* cr 2) 2 1)))<br />     (command "_.chprop" "l" "" "p" "c" 255 "")<br />     (setq lii (1+ lii))<br />   )<br /> <br /> <br />   ;; 结束事务<br />   (command "UNDO" "End")<br /> <br />   ;; 恢复设置<br />   (setvar "osmode" 4159)<br />   (princ "\n统计完成!")<br />   (princ)<br /> )<br /> <br /> ;; 筛选同心圆，只保留半径最大的圆<br /> (defun filter-largest-circles (ss fuzz / circles grouped result)<br />   (setq circles '()<br />         grouped '()<br />         result (ssadd))<br />   ;; 提取圆心和半径<br />   (repeat (sslength ss)<br />     (setq ent (entget (ssname ss 0)))<br />     (setq center (cdr (assoc 10 ent)))<br />     ;(setq radius (cdr (assoc 40 ent)))<br />     (setq radius (atof (rtos (* 1 (cdr (assoc 40 ent))) 2 2)))<br />     (setq circles (cons (list center radius (cdr (assoc 5 ent))) circles))<br />     (setq ss (ssdel (ssname ss 0) ss))<br />   )<br />   ;; 分组同心圆<br />   (foreach c1 circles<br />     (setq found nil)<br />     (foreach g grouped<br />       (if (and (not found)<br />                (< (distance (car c1) (car (car g))) fuzz)) ;; 判断是否同心<br />         (progn (setq g (cons c1 g)) (setq found t))<br />       )<br />     )<br />     (if (not found) (setq grouped (cons (list c1) grouped)))<br />   )<br />   ;; 选出每组中半径最大的圆<br />   (foreach g grouped<br />     (setq max-circle (car g))<br />     (foreach c g<br />       (if (> (cadr c) (cadr max-circle))<br />         (setq max-circle c)))<br />     ;; 添加最大圆到结果集<br />     (setq result (ssadd (handent (caddr max-circle)) result))<br />   )<br />   result<br /> )<br /> <br /> (defun BF-pickset-sortwithdxf (SE i INT FUZZ K / ENT INDEX LST NEWLST NEWSE TMP)<br />   (setq LST '() INDEX 0)<br />   (repeat (sslength SE)<br />     (setq ENT (entget (ssname SE INDEX))<br />           TMP (cdr (assoc i ENT)))<br />     (if (and INT<br />              (= (type INT) 'INT)<br />              (= (type TMP) 'list)<br />              (< INT (length TMP)))<br />       (setq TMP (nth INT TMP)))<br />     (setq LST (cons (list TMP (cdr (assoc 5 ENT))) LST))<br />     (setq INDEX (1+ INDEX))<br />   )<br />   (if (and FUZZ<br />            (or (= (type FUZZ) 'INT)<br />                (= (type FUZZ) 'REAL))<br />            (or (= (type TMP) 'INT)<br />                (= (type TMP) 'REAL)))<br />     (setq NEWLST<br />           (vl-sort LST<br />                    (function (lambda (E1 E2)<br />                                (< (+ (car E1) FUZZ) (car  E2)))))) <br />     (setq NEWLST<br />           (vl-sort LST<br />                    (function (lambda (E1 E2)<br />                                (< (car E1) (car E2)))))) <br />   )<br />   (if K<br />     (setq NEWLST (reverse NEWLST)))<br />   (setq NEWSE (ssadd))<br />   (foreach TMP NEWLST<br />     (setq NEWSE (ssadd (handent (cadr TMP)) NEWSE)))<br />   NEWSE<br /> )<br /> <br /> (prompt "\n 本程序可用圆孔统计；启动命令【K】")<br /> (prin1)<br />

GEGEYANG88

燕秀工具箱--圆数量统计--yx_ctu很好用而且准确

llsheng_73

因为半径是实数的，实数就存在精度问题，看似相等的几个实数完全可能不相等，所以建议在判断半径大小的地方通过equal带上你的容忍的精度进行判断，那样才能避免出现你图上那样的结果


(foreach c g
      (if (> (cadr c) (cadr max-circle))
        (setq max-circle c)))


改为 (foreach c g
     (or(equal (cadr c)  (cadr max-circle) fuzz)
            (setq max-circle c)))
应该就可以了，如果还不行，需要根据实际情况修改 (setq fuzz 0.01)的数值

听见天晴

llsheng_73 发表于 2024-11-18 11:00
因为半径是实数的，实数就存在精度问题，看似相等的几个实数完全可能不相等，所以建议在判断半径大小的地方 ...

谢谢大佬，我修改了试了下，还是和之前一样会算错， (setq fuzz 0.01)的数值 好像是那个同心圆的模糊距离，我改了以后 有多少偏差以外就还是算同心圆，还有其他办法吗

听见天晴

GEGEYANG88 发表于 2024-11-18 10:45
燕秀工具箱--圆数量统计--yx_ctu很好用而且准确

我是想在相同的孔边上写上字母，然后又能输出统计

paulpipi

帮顶，希望高手帮忙解决

GEGEYANG88

好厉害啊！

听见天晴

tempasdf 发表于 2024-11-18 18:04

测试过可以了，谢谢大神帮忙优化！

llsheng_73

1. (defun c:K(/ ss fuzz pt /pi4)
   
2.   (princ "\n选择要进行统计的圆(弧)对象-支持块参照")
   
3.   ;(setvar "osmode"(boole 7(getvar "osmode")16384))
   
4.   (and(setq ss(ssget'((0 . "CIRCLE,arc,insert"))))
   
5.       (or(setq text-height(getreal(strcat"\n请输入文字高度("(rtos(if text-height text-height 3.0)2 1)"): ")))
   
6.    (setq text-height 3.0))
   
7.       (setq fuzz 0.01 /pi4(* pi 0.25) pt(getpoint "\n选择输出基点:"))
   
8.       (vl-every(function(lambda(a / i txt r)
   
9.         (setq i(vl-position a ss)txt(chr(+ i 65))r(car a))
   
10.         (vl-every(function(lambda(a / p)
    
11.                 (entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)
    
12.                     (List"TEXT"txt"STANDARD""圆孔统计"4(setq p(polar a /pi4(* r 1.2)))p text-height 0.8 0 1)))))(cdr a))
    
13.         (entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)
    
14.             (List"TEXT"(strcat(substr(strcat txt"-"(itoa(1-(length a)))"          ")1 8)"Φ"(rtos(+ r r)2 1))
    
15.                  "STANDARD""圆孔统计"4(setq pt(mapcar'+(List 0(* text-height -1.5))pt))pt text-height 0.8 0 1)))))
    
16.          (setq ss(vl-sort(group-largest-circles ss fuzz)(function(lambda(a b)(<(car a)(car b)))))))
    
17.       )
    
18.   ;  (setvar "osmode"(boole 2(getvar "osmode")16384))
    
19.   ;  (princ)
    
20.   )
    
21. ;; 取最大半径筛选同心圆(弧)并按半径分组一--支持块内圆(弧)
    
22. (defun group-largest-circles(ss fuzz / i blocks ent bl p a l lst)
    
23.   (setq i -1 blocks(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'blocks))
    
24.   (repeat(sslength ss)
    
25.     (setq i(1+ i)ent(entget (ssname ss i)))
    
26.     (if(and(equal(assoc 0 ent)'(0 . "INSERT"))(equal(setq bl(cdr(assoc 41 ent)))(cdr(assoc 42 ent))1e-8)(setq p(cdr(assoc 10 ent))))
    
27.       (vlax-for a(vlax-invoke-method blocks'item(cdr(assoc 2 ent)))
    
28.   (and(vl-position(vlax-get-property a 'objectname)'("AcDbCircle""AcDbArc"))
    
29.       (setq a(entget(vlax-vla-object->ename a))
    
30.       l(cons(list(*(cdr(assoc 40 a))bl)(mapcar'+(mapcar'*(cdr(assoc 10 a))(list bl bl))p))l))))
    
31.       (setq l(cons(List(cdr(assoc 40 ent))(cdr(assoc 10 ent)))l))))
    
32.   (while l
    
33.     (setq a(car l)l(cdr l)r(car a)c(cadr a))
    
34.     (foreach b l
    
35.       (and(equal(cadr b)c fuzz)(setq a(list(max(car b)r)c)l(vl-remove b l))))
    
36.     (or(vl-position a lst)(setq lst(cons a lst))))
    
37.   (while lst
    
38.     (setq a(car lst)lst(cdr lst))
    
39.     (if(vl-some(function(lambda(x)(and(equal(car a)(car x)fuzz)(setq b x))))l)
    
40.       (setq l(subst(vl-list*(car b)(cadr a)(cdr b))b l))
    
41.       (setq l(cons a l)))))
    
42. (alert "\n 本程序可用圆孔统计；启动命令【K】")

(defun c:K(/ ss fuzz pt /pi4)<br />   (princ "\n选择要进行统计的圆(弧)对象-支持块参照")<br />   ;(setvar "osmode"(boole 7(getvar "osmode")16384))<br />   (and(setq ss(ssget'((0 . "CIRCLE,arc,insert"))))<br />       (or(setq text-height(getreal(strcat"\n请输入文字高度("(rtos(if text-height text-height 3.0)2 1)"): ")))<br />    (setq text-height 3.0))<br />       (setq fuzz 0.01 /pi4(* pi 0.25) pt(getpoint "\n选择输出基点:"))<br />       (vl-every(function(lambda(a / i txt r)<br />         (setq i(vl-position a ss)txt(chr(+ i 65))r(car a))<br />         (vl-every(function(lambda(a / p)<br />                 (entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)<br />                     (List"TEXT"txt"STANDARD""圆孔统计"4(setq p(polar a /pi4(* r 1.2)))p text-height 0.8 0 1)))))(cdr a))<br />         (entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)<br />             (List"TEXT"(strcat(substr(strcat txt"-"(itoa(1-(length a)))"          ")1 8)"Φ"(rtos(+ r r)2 1))<br />                  "STANDARD""圆孔统计"4(setq pt(mapcar'+(List 0(* text-height -1.5))pt))pt text-height 0.8 0 1)))))<br />          (setq ss(vl-sort(group-largest-circles ss fuzz)(function(lambda(a b)(<(car a)(car b)))))))<br />       )<br />   ;  (setvar "osmode"(boole 2(getvar "osmode")16384))<br />   ;  (princ)<br />   )<br /> ;; 取最大半径筛选同心圆(弧)并按半径分组一--支持块内圆(弧)<br /> (defun group-largest-circles(ss fuzz / i blocks ent bl p a l lst)<br />   (setq i -1 blocks(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'blocks))<br />   (repeat(sslength ss)<br />     (setq i(1+ i)ent(entget (ssname ss i)))<br />     (if(and(equal(assoc 0 ent)'(0 . "INSERT"))(equal(setq bl(cdr(assoc 41 ent)))(cdr(assoc 42 ent))1e-8)(setq p(cdr(assoc 10 ent))))<br />       (vlax-for a(vlax-invoke-method blocks'item(cdr(assoc 2 ent)))<br />   (and(vl-position(vlax-get-property a 'objectname)'("AcDbCircle""AcDbArc"))<br />       (setq a(entget(vlax-vla-object->ename a))<br />       l(cons(list(*(cdr(assoc 40 a))bl)(mapcar'+(mapcar'*(cdr(assoc 10 a))(list bl bl))p))l))))<br />       (setq l(cons(List(cdr(assoc 40 ent))(cdr(assoc 10 ent)))l))))<br />   (while l<br />     (setq a(car l)l(cdr l)r(car a)c(cadr a))<br />     (foreach b l<br />       (and(equal(cadr b)c fuzz)(setq a(list(max(car b)r)c)l(vl-remove b l))))<br />     (or(vl-position a lst)(setq lst(cons a lst))))<br />   (while lst<br />     (setq a(car lst)lst(cdr lst))<br />     (if(vl-some(function(lambda(x)(and(equal(car a)(car x)fuzz)(setq b x))))l)<br />       (setq l(subst(vl-list*(car b)(cadr a)(cdr b))b l))<br />       (setq l(cons a l)))))<br /> (alert "\n 本程序可用圆孔统计；启动命令【K】")