查找多层嵌套块内文本对象，并正确绘制圆形标记

jezli

主要目的在于检索当前dwg文件中的某些字符，并在其上绘制圆形便于查看标记。
目前我能成功在单行文本、多行文本、以及单层块内实现这个目的，但是无法在多层嵌套块中正确位置绘制圆形。而且每次多层嵌套块绘制出来的圆形都在图纸原点，我很q

1. (defun c:DrawCircleAtBlockText (/ *error* main acadDoc blks str dia)
   
2.   (vl-load-com)
   
3.   (setq foundCount 0)  ; 设置计数器为全局变量
   
4.   
   
5.   ;; 错误处理函数
   
6.   (defun *error* (msg)
   
7.     (if acadDoc (vla-EndUndoMark acadDoc))
   
8.     (princ (strcat "\n[DEBUG] 错误: " msg))
   
9.     (princ)
   
10.   )
    
11.   
    
12.   ;; 创建或获取图层
    
13.   (defun setup-layer (layerName colorIndex / layerObj layers)
    
14.     (setq layers (vla-get-Layers
    
15.                    (vla-get-ActiveDocument
    
16.                      (vlax-get-acad-object))))
    
17.    
    
18.     ;; 尝试获取已存在的图层
    
19.     (if (not (vl-catch-all-error-p
    
20.                (setq layerObj (vl-catch-all-apply 'vla-item
    
21.                                                  (list layers layerName)))))
    
22.       layerObj
    
23.       ;; 如果图层不存在，创建新图层
    
24.       (setq layerObj (vla-add layers layerName))
    
25.     )
    
26.    
    
27.     ;; 设置图层颜色
    
28.     (vla-put-Color layerObj colorIndex)
    
29.     layerName
    
30.   )
    
31.   
    
32.   ;; 计算总块数
    
33.   (defun count-total-blocks (blks / count)
    
34.     (setq count 0)
    
35.     (vlax-for blk blks
    
36.       (setq count (1+ count))
    
37.     )
    
38.     count
    
39.   )
    
40.   
    
41.   ;; 更新进度条
    
42.   (defun update-progress (current total / percent)
    
43.     (setq percent (fix (* (/ current total) 100.0)))
    
44.     (princ (strcat "\r处理进度: " (itoa percent) "%"))
    
45.     (if (= current total) (princ "\n"))
    
46.   )
    
47.   
    
48.   ;; 主处理函数
    
49.   (defun main ()
    
50.     (setq acadDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    
51.           blks (vla-get-Blocks acadDoc))
    
52.    
    
53.     ;; 处理图层
    
54.     (setup-layer "M-0-E" 6)
    
55.    
    
56.     ;; 获取并验证文字输入
    
57.     (while (not str)
    
58.       (setq str (getstring "\n请输入需要查找的文字内容: "))
    
59.       (cond
    
60.         ((= str "")
    
61.           (setq str nil)
    
62.           (princ "\n[DEBUG] 错误: 文字内容不能为空，请重新输入")
    
63.         )
    
64.         ((= str nil)
    
65.           (exit)
    
66.         )
    
67.       )
    
68.     )
    
69.    
    
70.     ;; 获取并验证直径输入
    
71.     (while (not dia)
    
72.       (setq dia (getdist "\n请输入圆形直径: "))
    
73.       (cond
    
74.         ((and dia (<= dia 0.0))
    
75.           (setq dia nil)
    
76.           (princ "\n[DEBUG] 错误: 直径必须大于0，请重新输入")
    
77.         )
    
78.         ((= dia nil)
    
79.           (exit)
    
80.         )
    
81.       )
    
82.     )
    
83.    
    
84.     (vla-StartUndoMark acadDoc)
    
85.    
    
86.     (if (and str dia)
    
87.       (progn
    
88.         (setq totalBlocks (count-total-blocks blks)
    
89.               currentBlock 0)
    
90.         (princ "\n[DEBUG] 开始处理，总块数: ")
    
91.         (princ totalBlocks)
    
92.         (vlax-for blkDef blks
    
93.           (setq currentBlock (1+ currentBlock))
    
94.           (update-progress currentBlock totalBlocks)
    
95.           (process-block-def blkDef str dia)
    
96.         )
    
97.         (princ (strcat "\n[DEBUG] 已成功创建 " (itoa foundCount) " 个圆形"))
    
98.       )
    
99.       (princ "\n[DEBUG] 操作已取消")
    
100.     )
     
101.     (vla-EndUndoMark acadDoc)
     
102.   )
     
103.   
     
104.        ;; 块定义处理
     
105.     (defun process-block-def (blkDef str dia / found)
     
106.       (princ (strcat "\n[DEBUG] 正在处理块定义: " (vla-get-Name blkDef)))
     
107.       
     
108.       ;; 首先处理普通文本对象
     
109.       (vlax-for obj blkDef
     
110.         (cond
     
111.           ((or (= (vla-get-ObjectName obj) "AcDbText")
     
112.                (= (vla-get-ObjectName obj) "AcDbMText"))
     
113.            (princ (strcat "\n[DEBUG] 找到文本对象，内容: " (vla-get-TextString obj)))
     
114.            (if (= (strcase (vla-get-TextString obj)) (strcase str))
     
115.              (progn
     
116.                (princ "\n[DEBUG] 文本内容匹配成功")
     
117.                (create-circle-at-text obj dia)
     
118.                (setq found t)
     
119.              )
     
120.            ))
     
121.           ;; 处理块参照
     
122.           ((= (vla-get-ObjectName obj) "AcDbBlockReference")
     
123.            (princ "\n[DEBUG] 找到块参照")
     
124.            (if (process-block-reference obj str dia)
     
125.              (setq found t)
     
126.            ))
     
127.         )
     
128.       )
     
129.       found
     
130.     )
     
131. 
     
132.     ;; 在普通文本位置创建圆
     
133.     (defun create-circle-at-text (textObj dia / textPt)
     
134.       (setq textPt (vlax-get textObj 'InsertionPoint))
     
135.       (princ (strcat "\n[DEBUG] 文本坐标: " (vl-princ-to-string textPt)))
     
136.       
     
137.       (if (entmakex
     
138.             (list
     
139.               '(0 . "CIRCLE")
     
140.               '(8 . "M-0-E")
     
141.               (cons 10 textPt)
     
142.               (cons 40 (/ dia 2.0))
     
143.             )
     
144.           )
     
145.         (progn
     
146.           (setq foundCount (1+ foundCount))
     
147.           (princ "\n[DEBUG] 创建圆形成功"))
     
148.         (princ "\n[DEBUG] 创建圆形失败"))
     
149.     )
     
150.    
     
151.     ;; 处理块参照中的文本
     
152.     (defun process-block-reference (blkRef str dia / blkDef found)
     
153.       (if (setq blkDef (vla-item blks (vla-get-Name blkRef)))
     
154.         (progn
     
155.           (princ (strcat "\n[DEBUG] 处理块参照: " (vla-get-Name blkRef)))
     
156.           (vlax-for obj blkDef
     
157.             (cond
     
158.               ;; 处理块中的文本
     
159.               ((or (= (vla-get-ObjectName obj) "AcDbText")
     
160.                    (= (vla-get-ObjectName obj) "AcDbMText"))
     
161.                (princ (strcat "\n[DEBUG] 块中找到文本，内容: " (vla-get-TextString obj)))
     
162.                (if (= (strcase (vla-get-TextString obj)) (strcase str))
     
163.                  (progn
     
164.                    (princ "\n[DEBUG] 块中文本匹配成功")
     
165.                    (create-circle-at-block-text obj blkRef dia)
     
166.                    (setq found t)
     
167.                  )
     
168.                ))
     
169.               ;; 处理嵌套块
     
170.               ((= (vla-get-ObjectName obj) "AcDbBlockReference")
     
171.                (if (process-block-reference obj str dia)
     
172.                  (setq found t)
     
173.                ))
     
174.             )
     
175.           )
     
176.         )
     
177.       )
     
178.       found
     
179.     )
     
180.    
     
181.     ;; 在块参照中的文本位置创建圆
     
182.     (defun create-circle-at-block-text (textObj blkRef dia / textPt mat worldPt)
     
183.       (setq textPt (vlax-get textObj 'InsertionPoint))
     
184.       (princ (strcat "\n[DEBUG] 块中文本局部坐标: " (vl-princ-to-string textPt)))
     
185.       
     
186.       ;; 获取块的变换矩阵
     
187.       (setq mat (get-cumulative-matrix blkRef))
     
188.       (setq worldPt (apply-matrix textPt mat))
     
189.       (princ (strcat "\n[DEBUG] 转换后的世界坐标: " (vl-princ-to-string worldPt)))
     
190.       
     
191.       (if (entmakex
     
192.             (list
     
193.               '(0 . "CIRCLE")
     
194.               '(8 . "M-0-E")
     
195.               (cons 10 worldPt)
     
196.               (cons 40 (/ dia 2.0))
     
197.             )
     
198.           )
     
199.         (progn
     
200.           (setq foundCount (1+ foundCount))
     
201.           (princ "\n[DEBUG] 创建圆形成功"))
     
202.         (princ "\n[DEBUG] 创建圆形失败"))
     
203.     )
     
204.    
     
205.     ;; 实例处理（用于块参照中的文本对象）
     
206.     ;; 将未使用的函数转换为注释
     
207.     ;; ===== 以下为未使用的函数，已注释 =====
     
208.     ;; process-block-instances 函数定义
     
209.     #|
     
210.     (defun process-block-instances (blkDef textObj dia / ss refID mat textPtWorld)
     
211.       (princ (strcat "\n[DEBUG] 处理块实例: " (vla-get-Name blkDef)))
     
212.       ;; 获取文本在块定义中的局部坐标
     
213.       (setq textPt (vlax-get textObj 'InsertionPoint))
     
214.       (princ (strcat "\n[DEBUG] 文本局部坐标: " (vl-princ-to-string textPt)))
     
215.       
     
216.       ;; 处理所有块实例
     
217.       (setq blkName (vla-get-Name blkDef)
     
218.             ss (ssget "_X" (list '(0 . "INSERT") (cons 2 blkName))))
     
219.       
     
220.       (if ss
     
221.         (progn
     
222.           (princ (strcat "\n[DEBUG] 找到 " (itoa (sslength ss)) " 个块实例"))
     
223.           (repeat (setq cnt (sslength ss))
     
224.             (setq refID (ssname ss (setq cnt (1- cnt))))
     
225.             
     
226.             ;; 转换为VLA对象并应用变换
     
227.             (if (setq refID (vlax-ename->vla-object refID))
     
228.               (progn
     
229.                 (setq mat (get-cumulative-matrix refID))
     
230.                 (setq textPtWorld (apply-matrix textPt mat))
     
231.                 (princ (strcat "\n[DEBUG] 转换后的世界坐标: " (vl-princ-to-string textPtWorld)))
     
232.                
     
233.                 ;; 创建圆
     
234.                 (if (entmakex
     
235.                       (list
     
236.                         '(0 . "CIRCLE")
     
237.                         '(8 . "M-0-E")
     
238.                         (cons 10 textPtWorld)
     
239.                         (cons 40 (/ dia 2.0))
     
240.                       )
     
241.                     )
     
242.                   (progn
     
243.                     (setq foundCount (1+ foundCount))
     
244.                     (princ "\n[DEBUG] 创建圆形成功"))
     
245.                   (princ "\n[DEBUG] 创建圆形失败"))
     
246.               )
     
247.             )
     
248.           )
     
249.         )
     
250.         (princ "\n[DEBUG] 未找到块实例")
     
251.       )
     
252.     )
     
253.    |#
     
254.     ;; 获取累积变换矩阵（递归处理嵌套块）
     
255.     (defun get-cumulative-matrix (blkRef / parentMatrix parentEnt)
     
256.       (setq parentMatrix (get-block-transform blkRef))
     
257.       
     
258.       ;; 获取当前块参照的所有者（父块）
     
259.       (if (and blkRef
     
260.                (setq parentEnt (vlax-vla-object->ename blkRef))
     
261.                (setq parentEnt (entnext parentEnt))
     
262.                (= "INSERT" (cdr (assoc 0 (entget parentEnt)))))
     
263.         ;; 如果还在嵌套块中，继续向上递归
     
264.         (if (setq parentObj (vlax-ename->vla-object parentEnt))
     
265.           (setq parentMatrix (multiply-matrices
     
266.                               (get-cumulative-matrix parentObj)
     
267.                               parentMatrix))
     
268.         )
     
269.       )
     
270.       parentMatrix
     
271.     )
     
272.    
     
273.     ;; 获取单个块的变换矩阵（平移、旋转、缩放）
     
274.     (defun get-block-transform (blkRef / insPt scaleX scaleY rotAng mat)
     
275.       (setq insPt  (vlax-get blkRef 'InsertionPoint)
     
276.             scaleX (vla-get-XScaleFactor blkRef)
     
277.             scaleY (vla-get-YScaleFactor blkRef)
     
278.             rotAng (vla-get-Rotation blkRef))
     
279.       
     
280.       ;; 构建变换矩阵（4x4齐次矩阵）
     
281.       (setq mat (list
     
282.                  (list (* scaleX (cos rotAng)) (* (- scaleY) (sin rotAng)) 0.0 (car insPt))
     
283.                  (list (* scaleX (sin rotAng)) (* scaleY (cos rotAng)) 0.0 (cadr insPt))
     
284.                  (list 0.0 0.0 1.0 (if (caddr insPt) (caddr insPt) 0.0))
     
285.                  (list 0.0 0.0 0.0 1.0)))
     
286.       mat
     
287.     )
     
288.    
     
289.     ;; 矩阵乘法（合并嵌套变换）
     
290.     (defun multiply-matrices (mat1 mat2 / result)
     
291.       (setq result (mapcar '(lambda (row)
     
292.                               (mapcar '(lambda (col)
     
293.                                         (apply '+ (mapcar '* row col)))
     
294.                               (apply 'mapcar (cons 'list mat2))))
     
295.                           mat1))
     
296.       result
     
297.     )
     
298.     ;; 应用矩阵变换到点
     
299.         (defun apply-matrix (pt mat / x y z)
     
300.           (setq x (car pt)
     
301.                 y (cadr pt)
     
302.                 z (caddr pt))
     
303.           (list
     
304.             (+ (* x (caar mat)) (* y (cadar mat)) (* z (caddar mat)) (cadddr (car mat)))
     
305.             (+ (* x (caadr mat)) (* y (cadadr mat)) (* z (caddr (cadr mat))) (cadddr (cadr mat)))
     
306.             (+ (* x (caaddr mat)) (* y (cadadr mat)) (* z (caddr (caddr mat))) (cadddr (caddr mat))))
     
307.         )
     
308.     #|
     
309.     ;; 增强嵌套块处理（递归遍历所有层级）
     
310.     (defun process-nested-block (blkDef str dia / obj)
     
311.       (vlax-for obj blkDef
     
312.         (cond
     
313.           ((= (vla-get-ObjectName obj) "AcDbBlockReference")
     
314.             (process-block-def
     
315.               (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
     
316.               (vla-get-Name obj))
     
317.               str dia)
     
318.           )
     
319.         )
     
320.       )
     
321.     )
     
322.     |#
     
323.     (main)
     
324.     (princ)
     
325. )
     

(defun c:DrawCircleAtBlockText (/ *error* main acadDoc blks str dia)<br />   (vl-load-com)<br />   (setq foundCount 0)  ; 设置计数器为全局变量<br />   <br />   ;; 错误处理函数<br />   (defun *error* (msg)<br />     (if acadDoc (vla-EndUndoMark acadDoc))<br />     (princ (strcat "\n[DEBUG] 错误: " msg))<br />     (princ)<br />   )<br />   <br />   ;; 创建或获取图层<br />   (defun setup-layer (layerName colorIndex / layerObj layers)<br />     (setq layers (vla-get-Layers <br />                    (vla-get-ActiveDocument <br />                      (vlax-get-acad-object))))<br />     <br />     ;; 尝试获取已存在的图层<br />     (if (not (vl-catch-all-error-p <br />                (setq layerObj (vl-catch-all-apply 'vla-item <br />                                                  (list layers layerName)))))<br />       layerObj<br />       ;; 如果图层不存在，创建新图层<br />       (setq layerObj (vla-add layers layerName))<br />     )<br />     <br />     ;; 设置图层颜色<br />     (vla-put-Color layerObj colorIndex)<br />     layerName<br />   )<br />   <br />   ;; 计算总块数<br />   (defun count-total-blocks (blks / count)<br />     (setq count 0)<br />     (vlax-for blk blks<br />       (setq count (1+ count))<br />     )<br />     count<br />   )<br />   <br />   ;; 更新进度条<br />   (defun update-progress (current total / percent)<br />     (setq percent (fix (* (/ current total) 100.0)))<br />     (princ (strcat "\r处理进度: " (itoa percent) "%"))<br />     (if (= current total) (princ "\n"))<br />   )<br />   <br />   ;; 主处理函数<br />   (defun main ()<br />     (setq acadDoc (vla-get-ActiveDocument (vlax-get-acad-object))<br />           blks (vla-get-Blocks acadDoc))<br />     <br />     ;; 处理图层<br />     (setup-layer "M-0-E" 6)<br />     <br />     ;; 获取并验证文字输入<br />     (while (not str)<br />       (setq str (getstring "\n请输入需要查找的文字内容: "))<br />       (cond <br />         ((= str "") <br />           (setq str nil)<br />           (princ "\n[DEBUG] 错误: 文字内容不能为空，请重新输入")<br />         )<br />         ((= str nil) <br />           (exit)<br />         )<br />       )<br />     )<br />     <br />     ;; 获取并验证直径输入<br />     (while (not dia)<br />       (setq dia (getdist "\n请输入圆形直径: "))<br />       (cond <br />         ((and dia (<= dia 0.0))<br />           (setq dia nil)<br />           (princ "\n[DEBUG] 错误: 直径必须大于0，请重新输入")<br />         )<br />         ((= dia nil)<br />           (exit)<br />         )<br />       )<br />     )<br />     <br />     (vla-StartUndoMark acadDoc)<br />     <br />     (if (and str dia)<br />       (progn<br />         (setq totalBlocks (count-total-blocks blks)<br />               currentBlock 0)<br />         (princ "\n[DEBUG] 开始处理，总块数: ")<br />         (princ totalBlocks)<br />         (vlax-for blkDef blks<br />           (setq currentBlock (1+ currentBlock))<br />           (update-progress currentBlock totalBlocks)<br />           (process-block-def blkDef str dia)<br />         )<br />         (princ (strcat "\n[DEBUG] 已成功创建 " (itoa foundCount) " 个圆形"))<br />       )<br />       (princ "\n[DEBUG] 操作已取消")<br />     )<br />     (vla-EndUndoMark acadDoc)<br />   )<br />   <br />        ;; 块定义处理<br />     (defun process-block-def (blkDef str dia / found)<br />       (princ (strcat "\n[DEBUG] 正在处理块定义: " (vla-get-Name blkDef)))<br />       <br />       ;; 首先处理普通文本对象<br />       (vlax-for obj blkDef<br />         (cond<br />           ((or (= (vla-get-ObjectName obj) "AcDbText")<br />                (= (vla-get-ObjectName obj) "AcDbMText"))<br />            (princ (strcat "\n[DEBUG] 找到文本对象，内容: " (vla-get-TextString obj)))<br />            (if (= (strcase (vla-get-TextString obj)) (strcase str))<br />              (progn<br />                (princ "\n[DEBUG] 文本内容匹配成功")<br />                (create-circle-at-text obj dia)<br />                (setq found t)<br />              )<br />            ))<br />           ;; 处理块参照<br />           ((= (vla-get-ObjectName obj) "AcDbBlockReference")<br />            (princ "\n[DEBUG] 找到块参照")<br />            (if (process-block-reference obj str dia)<br />              (setq found t)<br />            ))<br />         )<br />       )<br />       found<br />     )<br /> <br />     ;; 在普通文本位置创建圆<br />     (defun create-circle-at-text (textObj dia / textPt)<br />       (setq textPt (vlax-get textObj 'InsertionPoint))<br />       (princ (strcat "\n[DEBUG] 文本坐标: " (vl-princ-to-string textPt)))<br />       <br />       (if (entmakex<br />             (list<br />               '(0 . "CIRCLE")<br />               '(8 . "M-0-E")<br />               (cons 10 textPt)<br />               (cons 40 (/ dia 2.0))<br />             )<br />           )<br />         (progn<br />           (setq foundCount (1+ foundCount))<br />           (princ "\n[DEBUG] 创建圆形成功"))<br />         (princ "\n[DEBUG] 创建圆形失败"))<br />     )<br />     <br />     ;; 处理块参照中的文本<br />     (defun process-block-reference (blkRef str dia / blkDef found)<br />       (if (setq blkDef (vla-item blks (vla-get-Name blkRef)))<br />         (progn<br />           (princ (strcat "\n[DEBUG] 处理块参照: " (vla-get-Name blkRef)))<br />           (vlax-for obj blkDef<br />             (cond<br />               ;; 处理块中的文本<br />               ((or (= (vla-get-ObjectName obj) "AcDbText")<br />                    (= (vla-get-ObjectName obj) "AcDbMText"))<br />                (princ (strcat "\n[DEBUG] 块中找到文本，内容: " (vla-get-TextString obj)))<br />                (if (= (strcase (vla-get-TextString obj)) (strcase str))<br />                  (progn<br />                    (princ "\n[DEBUG] 块中文本匹配成功")<br />                    (create-circle-at-block-text obj blkRef dia)<br />                    (setq found t)<br />                  )<br />                ))<br />               ;; 处理嵌套块<br />               ((= (vla-get-ObjectName obj) "AcDbBlockReference")<br />                (if (process-block-reference obj str dia)<br />                  (setq found t)<br />                ))<br />             )<br />           )<br />         )<br />       )<br />       found<br />     )<br />     <br />     ;; 在块参照中的文本位置创建圆<br />     (defun create-circle-at-block-text (textObj blkRef dia / textPt mat worldPt)<br />       (setq textPt (vlax-get textObj 'InsertionPoint))<br />       (princ (strcat "\n[DEBUG] 块中文本局部坐标: " (vl-princ-to-string textPt)))<br />       <br />       ;; 获取块的变换矩阵<br />       (setq mat (get-cumulative-matrix blkRef))<br />       (setq worldPt (apply-matrix textPt mat))<br />       (princ (strcat "\n[DEBUG] 转换后的世界坐标: " (vl-princ-to-string worldPt)))<br />       <br />       (if (entmakex<br />             (list<br />               '(0 . "CIRCLE")<br />               '(8 . "M-0-E")<br />               (cons 10 worldPt)<br />               (cons 40 (/ dia 2.0))<br />             )<br />           )<br />         (progn<br />           (setq foundCount (1+ foundCount))<br />           (princ "\n[DEBUG] 创建圆形成功"))<br />         (princ "\n[DEBUG] 创建圆形失败"))<br />     )<br />     <br />     ;; 实例处理（用于块参照中的文本对象）<br />     ;; 将未使用的函数转换为注释<br />     ;; ===== 以下为未使用的函数，已注释 =====<br />     ;; process-block-instances 函数定义<br />     #|<br />     (defun process-block-instances (blkDef textObj dia / ss refID mat textPtWorld)<br />       (princ (strcat "\n[DEBUG] 处理块实例: " (vla-get-Name blkDef)))<br />       ;; 获取文本在块定义中的局部坐标<br />       (setq textPt (vlax-get textObj 'InsertionPoint))<br />       (princ (strcat "\n[DEBUG] 文本局部坐标: " (vl-princ-to-string textPt)))<br />       <br />       ;; 处理所有块实例<br />       (setq blkName (vla-get-Name blkDef)<br />             ss (ssget "_X" (list '(0 . "INSERT") (cons 2 blkName))))<br />       <br />       (if ss<br />         (progn<br />           (princ (strcat "\n[DEBUG] 找到 " (itoa (sslength ss)) " 个块实例"))<br />           (repeat (setq cnt (sslength ss))<br />             (setq refID (ssname ss (setq cnt (1- cnt))))<br />             <br />             ;; 转换为VLA对象并应用变换<br />             (if (setq refID (vlax-ename->vla-object refID))<br />               (progn<br />                 (setq mat (get-cumulative-matrix refID))<br />                 (setq textPtWorld (apply-matrix textPt mat))<br />                 (princ (strcat "\n[DEBUG] 转换后的世界坐标: " (vl-princ-to-string textPtWorld)))<br />                 <br />                 ;; 创建圆<br />                 (if (entmakex<br />                       (list<br />                         '(0 . "CIRCLE")<br />                         '(8 . "M-0-E")<br />                         (cons 10 textPtWorld)<br />                         (cons 40 (/ dia 2.0))<br />                       )<br />                     )<br />                   (progn<br />                     (setq foundCount (1+ foundCount))<br />                     (princ "\n[DEBUG] 创建圆形成功"))<br />                   (princ "\n[DEBUG] 创建圆形失败"))<br />               )<br />             )<br />           )<br />         )<br />         (princ "\n[DEBUG] 未找到块实例")<br />       )<br />     )<br />    |#<br />     ;; 获取累积变换矩阵（递归处理嵌套块）<br />     (defun get-cumulative-matrix (blkRef / parentMatrix parentEnt)<br />       (setq parentMatrix (get-block-transform blkRef))<br />       <br />       ;; 获取当前块参照的所有者（父块）<br />       (if (and blkRef <br />                (setq parentEnt (vlax-vla-object->ename blkRef))<br />                (setq parentEnt (entnext parentEnt))<br />                (= "INSERT" (cdr (assoc 0 (entget parentEnt)))))<br />         ;; 如果还在嵌套块中，继续向上递归<br />         (if (setq parentObj (vlax-ename->vla-object parentEnt))<br />           (setq parentMatrix (multiply-matrices <br />                               (get-cumulative-matrix parentObj)<br />                               parentMatrix))<br />         )<br />       )<br />       parentMatrix<br />     )<br />     <br />     ;; 获取单个块的变换矩阵（平移、旋转、缩放）<br />     (defun get-block-transform (blkRef / insPt scaleX scaleY rotAng mat)<br />       (setq insPt  (vlax-get blkRef 'InsertionPoint)<br />             scaleX (vla-get-XScaleFactor blkRef)<br />             scaleY (vla-get-YScaleFactor blkRef)<br />             rotAng (vla-get-Rotation blkRef))<br />       <br />       ;; 构建变换矩阵（4x4齐次矩阵）<br />       (setq mat (list <br />                  (list (* scaleX (cos rotAng)) (* (- scaleY) (sin rotAng)) 0.0 (car insPt))<br />                  (list (* scaleX (sin rotAng)) (* scaleY (cos rotAng)) 0.0 (cadr insPt))<br />                  (list 0.0 0.0 1.0 (if (caddr insPt) (caddr insPt) 0.0))<br />                  (list 0.0 0.0 0.0 1.0)))<br />       mat<br />     )<br />     <br />     ;; 矩阵乘法（合并嵌套变换）<br />     (defun multiply-matrices (mat1 mat2 / result)<br />       (setq result (mapcar '(lambda (row) <br />                               (mapcar '(lambda (col)<br />                                         (apply '+ (mapcar '* row col)))<br />                               (apply 'mapcar (cons 'list mat2))))<br />                           mat1))<br />       result<br />     )<br />     ;; 应用矩阵变换到点<br />         (defun apply-matrix (pt mat / x y z)<br />           (setq x (car pt)<br />                 y (cadr pt)<br />                 z (caddr pt))<br />           (list<br />             (+ (* x (caar mat)) (* y (cadar mat)) (* z (caddar mat)) (cadddr (car mat)))<br />             (+ (* x (caadr mat)) (* y (cadadr mat)) (* z (caddr (cadr mat))) (cadddr (cadr mat)))<br />             (+ (* x (caaddr mat)) (* y (cadadr mat)) (* z (caddr (caddr mat))) (cadddr (caddr mat))))<br />         )<br />     #|<br />     ;; 增强嵌套块处理（递归遍历所有层级）<br />     (defun process-nested-block (blkDef str dia / obj)<br />       (vlax-for obj blkDef<br />         (cond<br />           ((= (vla-get-ObjectName obj) "AcDbBlockReference")<br />             (process-block-def <br />               (vla-item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) <br />               (vla-get-Name obj)) <br />               str dia)<br />           )<br />         )<br />       )<br />     )<br />     |#<br />     (main)<br />     (princ)<br /> )<br />

xyp1964

ssyfeng

转换一下坐标应该就可以

kozmosovia

嵌套块要不停地计算嵌套矩阵再转换。比较简单的方式是将图块弄到DBX中，逐层分解到没有图块，然后过滤全图找到需要标记的文本，再根据文本位置在DWG中创建圆。

jezli

ssyfeng 发表于 2025-2-28 11:42
转换一下坐标应该就可以

我试了坐标转换，单层块没问题 多层嵌套块坐标转换画出来的圆形还是不在其位，会偏离，昨天弄了半天也没有解决。

jezli

kozmosovia 发表于 2025-2-28 11:44
嵌套块要不停地计算嵌套矩阵再转换。比较简单的方式是将图块弄到DBX中，逐层分解到没有图块，然后过滤全图 ...

哎，这不是我想要的结果，会破坏原图的完整性。但这确实是最简单的做法。

kozmosovia

jezli 发表于 2025-2-28 14:29
哎，这不是我想要的结果，会破坏原图的完整性。但这确实是最简单的做法。

不需要破坏DWG，explode是在DBX中进行的，对DWG没有任何影响

lijiao

楼主搞得过于复杂,实际上不存在嵌套块的处理

帮你修改了一下

2. (defun c:DrawCircleAtBlockText (/       ACADDOC    BLKS
   
3.         CIRCLE       DIA    FOUNDCOUNT
   
4.         STR       TEXTPT    TOTALBLOCKS
   
5.         *error*       process-block-def
   
6.              )
   
7.   (vl-load-com)
   
8. 
   
9.   ;; 错误处理函数
   
10.   (defun *error* (msg)
    
11.     (if  acadDoc
    
12.       (vla-EndUndoMark acadDoc)
    
13.     )
    
14.     (princ (strcat "\n[DEBUG] 错误: " msg))
    
15.     (princ)
    
16.   )
    
17.   ;; 块定义处理
    
18.   (defun process-block-def (blkDef str dia / found)
    
19.     (setq found 0)
    
20.     (vlax-for obj blkDef
    
21.       (if (and (or (= (vla-get-ObjectName obj) "AcDbText")
    
22.        (= (vla-get-ObjectName obj) "AcDbMText")
    
23.          )
    
24.          (= (strcase (vla-get-TextString obj)) (strcase str))
    
25.     )
    
26.   (progn
    
27.     (setq found (1+ found))
    
28.     (setq textPt (vla-get-InsertionPoint obj))
    
29.     (setq circle (vla-addcircle blkDef textPt (* dia 0.5)))
    
30.     (vla-put-layer circle "M-0-E")
    
31.   )
    
32.       )
    
33.     )
    
34.     found
    
35.   )
    
36. 
    
37. 
    
38.   (setq foundCount 0)      ; 设置计数器为全局变量
    
39.   (setq  acadDoc  (vla-get-ActiveDocument (vlax-get-acad-object))
    
40.   blks  (vla-get-Blocks acadDoc)
    
41.   )
    
42. 
    
43.   ;; 处理图层
    
44.   (if (not (tblsearch "layer" "M-0-E"))
    
45.     (entmake '((0 . "LAYER")
    
46.          (100 . "AcDbSymbolTableRecord")
    
47.          (100 . "AcDbLayerTableRecord")
    
48.          (70 . 0)
    
49.          (6 . "Continuous")
    
50.          (2 . "M-0-E")
    
51.          (62 . 6)
    
52.         )
    
53.     )
    
54.   )
    
55.   ;; 获取并验证文字输入
    
56.   (while (= (setq str (getstring "\n请输入需要查找的文字内容: ")) "")
    
57.     (princ "\n[DEBUG] 错误: 文字内容不能为空，请重新输入")
    
58.   )
    
59. 
    
60.   ;; 获取并验证直径输入
    
61.   (while (<= (setq dia (getdist "\n请输入圆形直径: ")) 0.0)
    
62.     (princ "\n[DEBUG] 错误: 直径必须大于0，请重新输入")
    
63.   )
    
64. 
    
65.   (vla-StartUndoMark acadDoc)
    
66.   (setq totalBlocks (vla-get-count blks))
    
67.   (acet-ui-progress "开始处理..." totalBlocks)
    
68.   (vlax-for blkDef blks
    
69.     (acet-ui-progress -1)
    
70.     (setq foundCount
    
71.      (+ foundCount (process-block-def blkDef str dia))
    
72.     )
    
73.   )
    
74.   (acet-ui-progress)
    
75.   (princ
    
76.     (strcat "\n[DEBUG] 已成功创建 " (itoa foundCount) " 个圆形")
    
77.   )
    
78.   (vla-EndUndoMark acadDoc)
    
79.   (vla-Regen acadDoc acActiveViewport)
    
80.   (princ)
    
81. )

(defun c:DrawCircleAtBlockText (/       ACADDOC    BLKS<br />         CIRCLE       DIA    FOUNDCOUNT<br />         STR       TEXTPT    TOTALBLOCKS<br />         *error*       process-block-def<br />              )<br />   (vl-load-com)<br /> <br />   ;; 错误处理函数<br />   (defun *error* (msg)<br />     (if  acadDoc<br />       (vla-EndUndoMark acadDoc)<br />     )<br />     (princ (strcat "\n[DEBUG] 错误: " msg))<br />     (princ)<br />   )<br />   ;; 块定义处理<br />   (defun process-block-def (blkDef str dia / found)<br />     (setq found 0)<br />     (vlax-for obj blkDef<br />       (if (and (or (= (vla-get-ObjectName obj) "AcDbText")<br />        (= (vla-get-ObjectName obj) "AcDbMText")<br />          )<br />          (= (strcase (vla-get-TextString obj)) (strcase str))<br />     )<br />   (progn<br />     (setq found (1+ found))<br />     (setq textPt (vla-get-InsertionPoint obj))<br />     (setq circle (vla-addcircle blkDef textPt (* dia 0.5)))<br />     (vla-put-layer circle "M-0-E")<br />   )<br />       )<br />     )<br />     found<br />   )<br /> <br /> <br />   (setq foundCount 0)      ; 设置计数器为全局变量<br />   (setq  acadDoc  (vla-get-ActiveDocument (vlax-get-acad-object))<br />   blks  (vla-get-Blocks acadDoc)<br />   )<br /> <br />   ;; 处理图层<br />   (if (not (tblsearch "layer" "M-0-E"))<br />     (entmake '((0 . "LAYER")<br />          (100 . "AcDbSymbolTableRecord")<br />          (100 . "AcDbLayerTableRecord")<br />          (70 . 0)<br />          (6 . "Continuous")<br />          (2 . "M-0-E")<br />          (62 . 6)<br />         )<br />     )<br />   )<br />   ;; 获取并验证文字输入<br />   (while (= (setq str (getstring "\n请输入需要查找的文字内容: ")) "")<br />     (princ "\n[DEBUG] 错误: 文字内容不能为空，请重新输入")<br />   )<br /> <br />   ;; 获取并验证直径输入<br />   (while (<= (setq dia (getdist "\n请输入圆形直径: ")) 0.0)<br />     (princ "\n[DEBUG] 错误: 直径必须大于0，请重新输入")<br />   )<br /> <br />   (vla-StartUndoMark acadDoc)<br />   (setq totalBlocks (vla-get-count blks))<br />   (acet-ui-progress "开始处理..." totalBlocks)<br />   (vlax-for blkDef blks<br />     (acet-ui-progress -1)<br />     (setq foundCount<br />      (+ foundCount (process-block-def blkDef str dia))<br />     )<br />   )<br />   (acet-ui-progress)<br />   (princ<br />     (strcat "\n[DEBUG] 已成功创建 " (itoa foundCount) " 个圆形")<br />   )<br />   (vla-EndUndoMark acadDoc)<br />   (vla-Regen acadDoc acActiveViewport)<br />   (princ)<br /> )

jezli

xyp1964 发表于 2025-2-27 18:36

求大佬赐教 点播