圆孔分类统计程序请大神优化，外径相同的圆经常被分成2种统计
程序也是论坛找的，觉得很方便，但是用起来有几个小问题，希望有大神帮忙修改一下：1.相同直径的圆经常会统计成不一样的（这是3D软件导出的2D图），希望同样外径的只有一种规格。
程序里面同心圆已经修改成只找外圆忽略内圆了，算一个沉头孔，这个不是BUG，需要保留。
2.块中的圆目前无法统计，如果能一起统计就更好了。
3.鼠标点击的位置是生成文字的左下角，希望改成左上角（不改变排列，还是直径小的在上面大的在下面）。
主要是第一点，其他点都可以用，只是希望能好，希望大神帮忙优化一下，谢谢，以下是目前程序的演示
源程序
测试的DWG
(defun c:K()
(princ "\n选择要进行统计的圆对象")
(setq ss (ssget (list (cons 0 "CIRCLE"))))
;; 获取用户输入的文字高度
(setq text-height (getreal "\n请输入文字高度（默认3.0）
: "))
(if (not text-height)
(setq text-height 3.0);; 如果未输入，使用默认值3.0
)
;; 选择输出基点
(setq pt (getpoint "\n选择输出基点:"))
(setq si 0 tx 65 px (car pt) py (cadr pt) li '() lii 0)
(setq os (getvar "osmode") om (getvar "cmdecho"))
(command "cmdecho" 0 "osmode" 0)
;; 设置文字高度
(setq circle-text-height text-height);; 圆右上角字母高度
(setq stats-text-height text-height) ;; 统计文字高度
;; 设置模糊距离
(setq fuzz 0.01) ;; 同心圆判断的模糊距离
;; 启动事务，以便一起撤销
(command "UNDO" "Begin")
;; 筛选出最大圆
(setq filtered-circles (filter-largest-circles ss fuzz))
;; 按圆半径对选择集进行排序
(setq filtered-circles (BF-pickset-sortwithdxf filtered-circles 40 nil 0.1 nil))
;; 遍历筛选后的圆集合，生成字母
(repeat (sslength filtered-circles)
(setq cs (ssname filtered-circles si) ce (entget cs))
(setq cp (cdr (assoc 10 ce))) ;; 获取圆心
;(setq cr (cdr (assoc 40 ce))) ;; 获取半径
(setq cr (atof (rtos (* 1 (cdr (assoc 40 ce))) 2 2))) ;; 获取半径
(if (setq lst (assoc cr li))
(setq ct (nth 1 lst) li (subst (list cr ct (1+ (nth 2 lst))) lst li))
(setq ct tx tx (1+ tx) li (cons (list cr ct 1) li))
)
;; 圆右上角计算
(setq cp1 (polar cp (/ pi 4) (* cr 1.2))) ;; 在圆外右上角，距离调整为1.2倍半径
(setq cp1 (trans cp1 0 1)) ;; 转换坐标
;; 在右上角生成字母
(command "_.text" cp1 circle-text-height 0 (chr ct))
(command "_.chprop" "l" "" "p" "c" 5 "")
(setq si (1+ si))
)
;; 输出统计文字
(foreach l li
(setq cp (list px (+ py (* lii (* stats-text-height 1.5))))) ;; 间距为统计文字高度的1.5倍
(setq cr (nth 0 l) ct (nth 1 l) cn (nth 2 l))
;; 拼接文字格式为 "A-1 %%c5.5"
(command "_.text" cp stats-text-height 0 (strcat (chr ct) "-" (itoa cn) "%%c" (rtos (* cr 2) 2 1)))
(command "_.chprop" "l" "" "p" "c" 255 "")
(setq lii (1+ lii))
)
;; 结束事务
(command "UNDO" "End")
;; 恢复设置
(setvar "osmode" 4159)
(princ "\n统计完成!")
(princ)
)
;; 筛选同心圆，只保留半径最大的圆
(defun filter-largest-circles (ss fuzz / circles grouped result)
(setq circles '()
grouped '()
result (ssadd))
;; 提取圆心和半径
(repeat (sslength ss)
(setq ent (entget (ssname ss 0)))
(setq center (cdr (assoc 10 ent)))
;(setq radius (cdr (assoc 40 ent)))
(setq radius (atof (rtos (* 1 (cdr (assoc 40 ent))) 2 2)))
(setq circles (cons (list center radius (cdr (assoc 5 ent))) circles))
(setq ss (ssdel (ssname ss 0) ss))
)
;; 分组同心圆
(foreach c1 circles
(setq found nil)
(foreach g grouped
(if (and (not found)
(< (distance (car c1) (car (car g))) fuzz)) ;; 判断是否同心
(progn (setq g (cons c1 g)) (setq found t))
)
)
(if (not found) (setq grouped (cons (list c1) grouped)))
)
;; 选出每组中半径最大的圆
(foreach g grouped
(setq max-circle (car g))
(foreach c g
(if (> (cadr c) (cadr max-circle))
(setq max-circle c)))
;; 添加最大圆到结果集
(setq result (ssadd (handent (caddr max-circle)) result))
)
result
)
(defun BF-pickset-sortwithdxf (SE i INT FUZZ K / ENT INDEX LST NEWLST NEWSE TMP)
(setq LST '() INDEX 0)
(repeat (sslength SE)
(setq ENT (entget (ssname SE INDEX))
TMP (cdr (assoc i ENT)))
(if (and INT
(= (type INT) 'INT)
(= (type TMP) 'list)
(< INT (length TMP)))
(setq TMP (nth INT TMP)))
(setq LST (cons (list TMP (cdr (assoc 5 ENT))) LST))
(setq INDEX (1+ INDEX))
)
(if (and FUZZ
(or (= (type FUZZ) 'INT)
(= (type FUZZ) 'REAL))
(or (= (type TMP) 'INT)
(= (type TMP) 'REAL)))
(setq NEWLST
(vl-sort LST
(function (lambda (E1 E2)
(< (+ (car E1) FUZZ) (carE2))))))
(setq NEWLST
(vl-sort LST
(function (lambda (E1 E2)
(< (car E1) (car E2))))))
)
(if K
(setq NEWLST (reverse NEWLST)))
(setq NEWSE (ssadd))
(foreach TMP NEWLST
(setq NEWSE (ssadd (handent (cadr TMP)) NEWSE)))
NEWSE
)
(prompt "\n 本程序可用圆孔统计；启动命令【K】")
(prin1)
燕秀工具箱--圆数量统计--yx_ctu很好用而且准确 本帖最后由 llsheng_73 于 2024-11-18 11:15 编辑
因为半径是实数的，实数就存在精度问题，看似相等的几个实数完全可能不相等，所以建议在判断半径大小的地方通过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很好用而且准确
我是想在相同的孔边上写上字母，然后又能输出统计:lol 帮顶，希望高手帮忙解决 好厉害啊！ tempasdf 发表于 2024-11-18 18:04
测试过可以了，谢谢大神帮忙优化！ 本帖最后由 llsheng_73 于 2024-11-19 16:56 编辑
(defun c:K(/ ss fuzz pt /pi4)
(princ "\n选择要进行统计的圆(弧)对象-支持块参照")
;(setvar "osmode"(boole 7(getvar "osmode")16384))
(and(setq ss(ssget'((0 . "CIRCLE,arc,insert"))))
(or(setq text-height(getreal(strcat"\n请输入文字高度("(rtos(if text-height text-height 3.0)2 1)"): ")))
(setq text-height 3.0))
(setq fuzz 0.01 /pi4(* pi 0.25) pt(getpoint "\n选择输出基点:"))
(vl-every(function(lambda(a / i txt r)
(setq i(vl-position a ss)txt(chr(+ i 65))r(car a))
(vl-every(function(lambda(a / p)
(entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)
(List"TEXT"txt"STANDARD""圆孔统计"4(setq p(polar a /pi4(* r 1.2)))p text-height 0.8 0 1)))))(cdr a))
(entmakex(mapcar(function cons)'(0 1 7 8 62 10 11 40 41 72 73)
(List"TEXT"(strcat(substr(strcat txt"-"(itoa(1-(length a)))" ")1 8)"Φ"(rtos(+ r r)2 1))
"STANDARD""圆孔统计"4(setq pt(mapcar'+(List 0(* text-height -1.5))pt))pt text-height 0.8 0 1)))))
(setq ss(vl-sort(group-largest-circles ss fuzz)(function(lambda(a b)(<(car a)(car b)))))))
)
;(setvar "osmode"(boole 2(getvar "osmode")16384))
;(princ)
)
;; 取最大半径筛选同心圆(弧)并按半径分组一--支持块内圆(弧)
(defun group-largest-circles(ss fuzz / i blocks ent bl p a l lst)
(setq i -1 blocks(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activedocument)'blocks))
(repeat(sslength ss)
(setq i(1+ i)ent(entget (ssname ss i)))
(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))))
(vlax-for a(vlax-invoke-method blocks'item(cdr(assoc 2 ent)))
(and(vl-position(vlax-get-property a 'objectname)'("AcDbCircle""AcDbArc"))
(setq a(entget(vlax-vla-object->ename a))
l(cons(list(*(cdr(assoc 40 a))bl)(mapcar'+(mapcar'*(cdr(assoc 10 a))(list bl bl))p))l))))
(setq l(cons(List(cdr(assoc 40 ent))(cdr(assoc 10 ent)))l))))
(while l
(setq a(car l)l(cdr l)r(car a)c(cadr a))
(foreach b l
(and(equal(cadr b)c fuzz)(setq a(list(max(car b)r)c)l(vl-remove b l))))
(or(vl-position a lst)(setq lst(cons a lst))))
(while lst
(setq a(car lst)lst(cdr lst))
(if(vl-some(function(lambda(x)(and(equal(car a)(car x)fuzz)(setq b x))))l)
(setq l(subst(vl-list*(car b)(cadr a)(cdr b))b l))
(setq l(cons a l)))))
(alert "\n 本程序可用圆孔统计；启动命令【K】")
页:
[1]
2