哪位大神能把这个计算面积的插件完善一下。。。

amook147

这个是用AI写的 ，想让其每次计算完面积 每个图形内会有单独的面积结果用文字显示出来，最后矩形图减去那个小圆以后剩下的面积是多少也能出个结果用文本的形式插入到图中心。。。
说白了就是 框选的图形每个都有单独的计算结果   如果有相减的图形  把减去内部图形以后剩下的面积是多少 显示出来    然后手动单独插入总面积
自己用AI尝试了 N百次了  就是达不到我想的结果。。。  

1. (defun c:jsmj (/ *error* totalArea ss i ent obj areaVal op cmdEcho
   
2.                 unitKey unitName baseUnit scaleFactor insUnits finalArea textHeight
   
3.                 insertPoint textContent unclosedCount originalLayer)
   
4.   (vl-load-com)
   
5.   
   
6.   ;;; 错误处理函数
   
7.   (defun *error* (msg)
   
8.     (if cmdEcho (setvar "CMDECHO" cmdEcho))
   
9.     (if originalLayer (setvar "CLAYER" originalLayer))
   
10.     (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
    
11.       (princ (strcat "\n错误: " msg))
    
12.     )
    
13.     (princ)
    
14.   )
    
15.   
    
16.   ; 保存当前设置
    
17.   (setq cmdEcho (getvar "CMDECHO"))
    
18.   (setq originalLayer (getvar "CLAYER"))
    
19.   (setvar "CMDECHO" 0)
    
20.   (setq totalArea 0.0)
    
21.   (setq unclosedCount 0)
    
22.   
    
23.   ;;; 获取CAD的插入单位设置
    
24.   (setq insUnits (getvar "INSUNITS"))
    
25.   (setq baseUnit
    
26.     (cond
    
27.       ((= insUnits 4) "毫米")  ; 毫米
    
28.       ((= insUnits 5) "厘米")  ; 厘米
    
29.       ((= insUnits 6) "米")    ; 米
    
30.       (t "毫米")              ; 其他单位默认为毫米
    
31.     )
    
32.   )
    
33.   
    
34.   ;;; 单位选择 - 基于CAD实际单位
    
35.   (initget "1 2 3")
    
36.   (setq unitKey (getkword (strcat "\n请选择面积单位 [毫米(1)/厘米(2)/米(3)] <" baseUnit ">: ")))
    
37.   
    
38.   ;;; 设置目标单位和换算系数
    
39.   (cond
    
40.     ((and (null unitKey) (eq baseUnit "毫米")) (setq unitName "平方毫米" scaleFactor 1.0))
    
41.     ((and (null unitKey) (eq baseUnit "厘米")) (setq unitName "平方厘米" scaleFactor 1.0))
    
42.     ((and (null unitKey) (eq baseUnit "米"))   (setq unitName "平方米"   scaleFactor 1.0))
    
43.     ((eq unitKey "1") (setq unitName "平方毫米" scaleFactor 1.0))
    
44.     ((eq unitKey "2") (setq unitName "平方厘米" scaleFactor 1.0))
    
45.     ((eq unitKey "3") (setq unitName "平方米"   scaleFactor 1.0))
    
46.     (t (setq unitName "平方毫米" scaleFactor 1.0)) ; 无效输入时使用默认值
    
47.   )
    
48.   
    
49.   ;;; 根据CAD单位设置计算换算系数
    
50.   (cond
    
51.     ((and (eq baseUnit "毫米") (eq unitName "平方厘米")) (setq scaleFactor 0.01))
    
52.     ((and (eq baseUnit "毫米") (eq unitName "平方米"))   (setq scaleFactor 0.000001))
    
53.     ((and (eq baseUnit "厘米") (eq unitName "平方毫米")) (setq scaleFactor 100.0))
    
54.     ((and (eq baseUnit "厘米") (eq unitName "平方米"))   (setq scaleFactor 0.0001))
    
55.     ((and (eq baseUnit "米")   (eq unitName "平方毫米")) (setq scaleFactor 1000000.0))
    
56.     ((and (eq baseUnit "米")   (eq unitName "平方厘米")) (setq scaleFactor 10000.0))
    
57.   )
    
58.   
    
59.   ;;; 未封闭图形检测函数 - 检测到未封闭图形即标记并返回t
    
60.   (defun check-closure (ent index)
    
61.     (setq dxfData (entget ent)
    
62.           objType (cdr (assoc 0 dxfData))
    
63.           isClosed nil
    
64.           coords nil)
    
65.    
    
66.     ; 仅检测多段线的封闭性
    
67.     (if (wcmatch objType "POLYLINE,LWPOLYLINE")
    
68.       (progn
    
69.         ; 判断封闭状态
    
70.         (if (assoc 70 dxfData)
    
71.           (setq isClosed (/= (logand (cdr (assoc 70 dxfData)) 1) 0))
    
72.           (setq isClosed nil)
    
73.         )
    
74.         
    
75.         ; 处理未封闭多段线
    
76.         (if (not isClosed)
    
77.           (progn
    
78.             ; 命令行提示未封闭信息
    
79.             (princ (strcat "\n【错误】对象" (itoa (1+ index)) "是未封闭的" objType))
    
80.             
    
81.             ; 获取多段线顶点坐标并标记开口
    
82.             (setq coords (vlax-get (vlax-ename->vla-object ent) 'Coordinates))
    
83.             (if (>= (length coords) 4) ; 确保有足够的坐标点
    
84.               (progn
    
85.                 (setq startPt (list (car coords) (cadr coords) 0.0) ; 起点
    
86.                       endPt (list (nth (- (length coords) 2) coords) ; 终点（开口处）
    
87.                                  (nth (- (length coords) 1) coords)
    
88.                                  0.0))
    
89.                
    
90.                 ; 绘制红色提示线（连接开口的起点和终点）
    
91.                 (entmakex (list (cons 0 "LINE")
    
92.                                (cons 10 startPt)
    
93.                                (cons 11 endPt)
    
94.                                (cons 62 1) ; 红色
    
95.                                (cons 8 originalLayer))) ; 使用当前默认图层
    
96.                 (princ "\n已在开口处标记红色提示线")
    
97.               )
    
98.             )
    
99.             (setq unclosedCount (1+ unclosedCount))
    
100.             t ; 返回t表示发现未封闭图形
     
101.           )
     
102.           nil ; 返回nil表示已封闭
     
103.         )
     
104.       )
     
105.       nil ; 非多段线默认返回nil
     
106.     )
     
107.   )
     
108.   
     
109.   ;;; 处理选择集并检查封闭性
     
110.   (defun process-selection-closure (ss)
     
111.     (setq i 0)
     
112.     (repeat (sslength ss)
     
113.       (setq ent (ssname ss i))
     
114.       
     
115.       ; 检查图形是否封闭
     
116.       (if (check-closure ent i)
     
117.         (progn
     
118.           ; 准备错误提示信息
     
119.           (setq msg (strcat
     
120.                      "检测到未封闭图形，请将图形封闭后再进行计算\n"
     
121.                      "共检测到 " (itoa unclosedCount) " 个未封闭图形\n"
     
122.                      "未封闭处已用红色线条标记"))
     
123.          
     
124.           ; 显示错误提示对话框
     
125.           (alert msg)
     
126.          
     
127.           ; 命令行补充提示
     
128.           (princ (strcat "\n\n" msg))
     
129.           (cleanup-and-exit) ; 执行清理并退出
     
130.         )
     
131.       )
     
132.       (setq i (1+ i))
     
133.     )
     
134.     t ; 全部封闭返回t
     
135.   )
     
136.   
     
137.   ;;; 处理选择集并计算面积
     
138.   (defun process-selection-calc (ss addToTotal)
     
139.     (setq i 0)
     
140.     (repeat (sslength ss)
     
141.       (setq ent (ssname ss i)
     
142.             obj (vlax-ename->vla-object ent))
     
143.       
     
144.       (if (vlax-property-available-p obj 'Area)
     
145.         (progn
     
146.           (setq areaVal (vla-get-area obj))
     
147.           (if addToTotal
     
148.             (setq totalArea (+ totalArea areaVal))
     
149.             (setq totalArea (- totalArea areaVal))
     
150.           )
     
151.           (princ (strcat "\n对象" (itoa (1+ i)) "面积: "
     
152.                         (rtos (* areaVal scaleFactor) 2 4) " " unitName))
     
153.         )
     
154.         (princ (strcat "\n对象" (itoa (1+ i)) ": 无法计算面积，已跳过"))
     
155.       )
     
156.       (setq i (1+ i))
     
157.     )
     
158.     (princ (strcat "\n当前总面积: " (rtos (* totalArea scaleFactor) 2 4) " " unitName))
     
159.   )
     
160.   
     
161.   ;;; 清理并退出函数
     
162.   (defun cleanup-and-exit ()
     
163.     (setvar "CMDECHO" cmdEcho)
     
164.     (setvar "CLAYER" originalLayer)
     
165.     (princ "\n命令已退出")
     
166.     (princ)
     
167.     (exit)
     
168.   )
     
169.   
     
170.   ;;; 初始选择图形
     
171.   (princ "\n请选择需要计算面积的图形...")
     
172.   (setq ss (ssget))
     
173.   (if (not ss)
     
174.     (progn
     
175.       (princ "\n未选择对象，命令取消")
     
176.       (cleanup-and-exit)
     
177.     )
     
178.   )
     
179.   
     
180.   ;;; 先检测所有选择对象的封闭性
     
181.   (princ "\n正在检测图形封闭性...")
     
182.   (if (process-selection-closure ss)
     
183.     (progn
     
184.       ; 所有图形都封闭，开始计算面积
     
185.       (princ "\n所有图形均已封闭，开始计算面积...")
     
186.       (process-selection-calc ss t)
     
187.       
     
188.       ;;; 操作循环
     
189.       (while T
     
190.         (initget "A B E")
     
191.         (setq op (getkword "\n选择操作 [增加(A)/减去(B)/结束(E)] <E>: "))
     
192.         
     
193.         (cond
     
194.           ((or (null op) (eq op "E"))
     
195.             (setq finalArea (* totalArea scaleFactor))
     
196.             (princ (strcat "\n最终面积 = " (rtos finalArea 2 4) " " unitName))
     
197.             
     
198.             ;;; 获取文本高度
     
199.             (setq textHeight (getdist "\n请输入文本高度 <3.0>: "))
     
200.             (if (null textHeight) (setq textHeight 3.0))
     
201.             
     
202.             ;;; 获取插入点
     
203.             (setq insertPoint (getpoint "\n请指定文本插入点: "))
     
204.             
     
205.             ;;; 创建文本内容
     
206.             (setq textContent (strcat "面积: " (rtos finalArea 2 4) " " unitName))
     
207.             
     
208.             ;;; 创建文本对象
     
209.             (command "_.TEXT" insertPoint textHeight 0 textContent)
     
210.             
     
211.             (princ (strcat "\n已创建面积文本: " textContent))
     
212.             (cleanup-and-exit)
     
213.           )
     
214.          
     
215.           ((eq op "A")
     
216.             (princ "\n请选择需要增加面积的图形...")
     
217.             (setq ss (ssget))
     
218.             (if (not ss)
     
219.               (princ "\n未选择对象")
     
220.               (progn
     
221.                 ; 先检测新增对象的封闭性
     
222.                 (if (process-selection-closure ss)
     
223.                   (process-selection-calc ss t)
     
224.                 )
     
225.               )
     
226.             )
     
227.           )
     
228.          
     
229.           ((eq op "B")
     
230.             (princ "\n请选择需要减去面积的图形...")
     
231.             (setq ss (ssget))
     
232.             (if (not ss)
     
233.               (princ "\n未选择对象")
     
234.               (progn
     
235.                 ; 先检测要减去对象的封闭性
     
236.                 (if (process-selection-closure ss)
     
237.                   (process-selection-calc ss nil)
     
238.                 )
     
239.               )
     
240.             )
     
241.           )
     
242.         )
     
243.       )
     
244.     )
     
245.   )
     
246.   
     
247.   ; 恢复原始设置
     
248.   (cleanup-and-exit)
     
249. )
     
250. 
     
251. ;;; 显示加载信息
     
252. (princ "\n带强制封闭检测的面积计算插件已加载，输入命令: jsmj 启动")
     
253. (princ)

(defun c:jsmj (/ *error* totalArea ss i ent obj areaVal op cmdEcho <br />                 unitKey unitName baseUnit scaleFactor insUnits finalArea textHeight <br />                 insertPoint textContent unclosedCount originalLayer)<br />   (vl-load-com)<br />   <br />   ;;; 错误处理函数<br />   (defun *error* (msg)<br />     (if cmdEcho (setvar "CMDECHO" cmdEcho))<br />     (if originalLayer (setvar "CLAYER" originalLayer))<br />     (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))<br />       (princ (strcat "\n错误: " msg))<br />     )<br />     (princ)<br />   )<br />   <br />   ; 保存当前设置<br />   (setq cmdEcho (getvar "CMDECHO"))<br />   (setq originalLayer (getvar "CLAYER"))<br />   (setvar "CMDECHO" 0)<br />   (setq totalArea 0.0)<br />   (setq unclosedCount 0)<br />   <br />   ;;; 获取CAD的插入单位设置<br />   (setq insUnits (getvar "INSUNITS"))<br />   (setq baseUnit <br />     (cond<br />       ((= insUnits 4) "毫米")  ; 毫米<br />       ((= insUnits 5) "厘米")  ; 厘米<br />       ((= insUnits 6) "米")    ; 米<br />       (t "毫米")              ; 其他单位默认为毫米<br />     )<br />   )<br />   <br />   ;;; 单位选择 - 基于CAD实际单位<br />   (initget "1 2 3")<br />   (setq unitKey (getkword (strcat "\n请选择面积单位 [毫米(1)/厘米(2)/米(3)] <" baseUnit ">: ")))<br />   <br />   ;;; 设置目标单位和换算系数<br />   (cond<br />     ((and (null unitKey) (eq baseUnit "毫米")) (setq unitName "平方毫米" scaleFactor 1.0))<br />     ((and (null unitKey) (eq baseUnit "厘米")) (setq unitName "平方厘米" scaleFactor 1.0))<br />     ((and (null unitKey) (eq baseUnit "米"))   (setq unitName "平方米"   scaleFactor 1.0))<br />     ((eq unitKey "1") (setq unitName "平方毫米" scaleFactor 1.0))<br />     ((eq unitKey "2") (setq unitName "平方厘米" scaleFactor 1.0))<br />     ((eq unitKey "3") (setq unitName "平方米"   scaleFactor 1.0))<br />     (t (setq unitName "平方毫米" scaleFactor 1.0)) ; 无效输入时使用默认值<br />   )<br />   <br />   ;;; 根据CAD单位设置计算换算系数<br />   (cond<br />     ((and (eq baseUnit "毫米") (eq unitName "平方厘米")) (setq scaleFactor 0.01))<br />     ((and (eq baseUnit "毫米") (eq unitName "平方米"))   (setq scaleFactor 0.000001))<br />     ((and (eq baseUnit "厘米") (eq unitName "平方毫米")) (setq scaleFactor 100.0))<br />     ((and (eq baseUnit "厘米") (eq unitName "平方米"))   (setq scaleFactor 0.0001))<br />     ((and (eq baseUnit "米")   (eq unitName "平方毫米")) (setq scaleFactor 1000000.0))<br />     ((and (eq baseUnit "米")   (eq unitName "平方厘米")) (setq scaleFactor 10000.0))<br />   )<br />   <br />   ;;; 未封闭图形检测函数 - 检测到未封闭图形即标记并返回t<br />   (defun check-closure (ent index)<br />     (setq dxfData (entget ent)<br />           objType (cdr (assoc 0 dxfData))<br />           isClosed nil<br />           coords nil)<br />     <br />     ; 仅检测多段线的封闭性<br />     (if (wcmatch objType "POLYLINE,LWPOLYLINE")<br />       (progn<br />         ; 判断封闭状态<br />         (if (assoc 70 dxfData)<br />           (setq isClosed (/= (logand (cdr (assoc 70 dxfData)) 1) 0))<br />           (setq isClosed nil)<br />         )<br />         <br />         ; 处理未封闭多段线<br />         (if (not isClosed)<br />           (progn<br />             ; 命令行提示未封闭信息<br />             (princ (strcat "\n【错误】对象" (itoa (1+ index)) "是未封闭的" objType))<br />             <br />             ; 获取多段线顶点坐标并标记开口<br />             (setq coords (vlax-get (vlax-ename->vla-object ent) 'Coordinates))<br />             (if (>= (length coords) 4) ; 确保有足够的坐标点<br />               (progn<br />                 (setq startPt (list (car coords) (cadr coords) 0.0) ; 起点<br />                       endPt (list (nth (- (length coords) 2) coords) ; 终点（开口处）<br />                                  (nth (- (length coords) 1) coords)<br />                                  0.0))<br />                 <br />                 ; 绘制红色提示线（连接开口的起点和终点）<br />                 (entmakex (list (cons 0 "LINE")<br />                                (cons 10 startPt)<br />                                (cons 11 endPt)<br />                                (cons 62 1) ; 红色<br />                                (cons 8 originalLayer))) ; 使用当前默认图层<br />                 (princ "\n已在开口处标记红色提示线")<br />               )<br />             )<br />             (setq unclosedCount (1+ unclosedCount))<br />             t ; 返回t表示发现未封闭图形<br />           )<br />           nil ; 返回nil表示已封闭<br />         )<br />       )<br />       nil ; 非多段线默认返回nil<br />     )<br />   )<br />   <br />   ;;; 处理选择集并检查封闭性<br />   (defun process-selection-closure (ss)<br />     (setq i 0)<br />     (repeat (sslength ss)<br />       (setq ent (ssname ss i))<br />       <br />       ; 检查图形是否封闭<br />       (if (check-closure ent i)<br />         (progn<br />           ; 准备错误提示信息<br />           (setq msg (strcat <br />                      "检测到未封闭图形，请将图形封闭后再进行计算\n"<br />                      "共检测到 " (itoa unclosedCount) " 个未封闭图形\n"<br />                      "未封闭处已用红色线条标记"))<br />           <br />           ; 显示错误提示对话框<br />           (alert msg)<br />           <br />           ; 命令行补充提示<br />           (princ (strcat "\n\n" msg))<br />           (cleanup-and-exit) ; 执行清理并退出<br />         )<br />       )<br />       (setq i (1+ i))<br />     )<br />     t ; 全部封闭返回t<br />   )<br />   <br />   ;;; 处理选择集并计算面积<br />   (defun process-selection-calc (ss addToTotal)<br />     (setq i 0)<br />     (repeat (sslength ss)<br />       (setq ent (ssname ss i)<br />             obj (vlax-ename->vla-object ent))<br />       <br />       (if (vlax-property-available-p obj 'Area)<br />         (progn<br />           (setq areaVal (vla-get-area obj))<br />           (if addToTotal<br />             (setq totalArea (+ totalArea areaVal))<br />             (setq totalArea (- totalArea areaVal))<br />           )<br />           (princ (strcat "\n对象" (itoa (1+ i)) "面积: " <br />                         (rtos (* areaVal scaleFactor) 2 4) " " unitName))<br />         )<br />         (princ (strcat "\n对象" (itoa (1+ i)) ": 无法计算面积，已跳过"))<br />       )<br />       (setq i (1+ i))<br />     )<br />     (princ (strcat "\n当前总面积: " (rtos (* totalArea scaleFactor) 2 4) " " unitName))<br />   )<br />   <br />   ;;; 清理并退出函数<br />   (defun cleanup-and-exit ()<br />     (setvar "CMDECHO" cmdEcho)<br />     (setvar "CLAYER" originalLayer)<br />     (princ "\n命令已退出")<br />     (princ)<br />     (exit)<br />   )<br />   <br />   ;;; 初始选择图形<br />   (princ "\n请选择需要计算面积的图形...")<br />   (setq ss (ssget))<br />   (if (not ss)<br />     (progn<br />       (princ "\n未选择对象，命令取消")<br />       (cleanup-and-exit)<br />     )<br />   )<br />   <br />   ;;; 先检测所有选择对象的封闭性<br />   (princ "\n正在检测图形封闭性...")<br />   (if (process-selection-closure ss)<br />     (progn<br />       ; 所有图形都封闭，开始计算面积<br />       (princ "\n所有图形均已封闭，开始计算面积...")<br />       (process-selection-calc ss t)<br />       <br />       ;;; 操作循环<br />       (while T<br />         (initget "A B E")<br />         (setq op (getkword "\n选择操作 [增加(A)/减去(B)/结束(E)] <E>: "))<br />         <br />         (cond<br />           ((or (null op) (eq op "E"))<br />             (setq finalArea (* totalArea scaleFactor))<br />             (princ (strcat "\n最终面积 = " (rtos finalArea 2 4) " " unitName))<br />             <br />             ;;; 获取文本高度<br />             (setq textHeight (getdist "\n请输入文本高度 <3.0>: "))<br />             (if (null textHeight) (setq textHeight 3.0))<br />             <br />             ;;; 获取插入点<br />             (setq insertPoint (getpoint "\n请指定文本插入点: "))<br />             <br />             ;;; 创建文本内容<br />             (setq textContent (strcat "面积: " (rtos finalArea 2 4) " " unitName))<br />             <br />             ;;; 创建文本对象<br />             (command "_.TEXT" insertPoint textHeight 0 textContent)<br />             <br />             (princ (strcat "\n已创建面积文本: " textContent))<br />             (cleanup-and-exit)<br />           )<br />           <br />           ((eq op "A")<br />             (princ "\n请选择需要增加面积的图形...")<br />             (setq ss (ssget))<br />             (if (not ss)<br />               (princ "\n未选择对象")<br />               (progn<br />                 ; 先检测新增对象的封闭性<br />                 (if (process-selection-closure ss)<br />                   (process-selection-calc ss t)<br />                 )<br />               )<br />             )<br />           )<br />           <br />           ((eq op "B")<br />             (princ "\n请选择需要减去面积的图形...")<br />             (setq ss (ssget))<br />             (if (not ss)<br />               (princ "\n未选择对象")<br />               (progn<br />                 ; 先检测要减去对象的封闭性<br />                 (if (process-selection-closure ss)<br />                   (process-selection-calc ss nil)<br />                 )<br />               )<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   <br />   ; 恢复原始设置<br />   (cleanup-and-exit)<br /> )<br /> <br /> ;;; 显示加载信息<br /> (princ "\n带强制封闭检测的面积计算<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">插件</a>已加载，输入命令: jsmj 启动")<br /> (princ)

amook147

bskidtf 发表于 2025-8-7 18:15
AI写的让AI去完善。

不知道怎么删除帖子 已经完善了

bskidtf

AI写的让AI去完善。

czb203

感谢大佬的分享ai

yonjay

直接扣除内部岛面积直接显示到图形质心不行吗？

mashanjie

完善的能否分享一下~楼主辛苦了

amook147

yonjay 发表于 2025-8-7 21:46
直接扣除内部岛面积直接显示到图形质心不行吗？

lilanjun101

谢谢朋友，很好用，如果再有个统计周长的更好

amook147

lilanjun101 发表于 2025-8-13 10:31
谢谢朋友，很好用，如果再有个统计周长的更好

这个本来是我自己用的，  不需要那么多功能    后期我在加上统计周长功能。。。