求助调试一下这个简单对齐的程序

andyzha

这个简单对齐的程序实现的功能：动态简单对齐(支持UCS,支持选集及块内对齐)，通过参照点和对齐点动态对齐选定对象，特点：1.支持UCS坐标系，2.支持选择集及块内对象对齐，3.动态预览效果，4.可调整缩放比例
但是在cad2020下一直报错，求大佬帮忙调试一下。

2. ;;; ==============================================================
   
3. ;;;                 动态简单对齐工具 (TT1命令)
   
4. ;;; 功能：动态简单对齐(支持UCS,支持选集及块内对齐)，通过参照点和对齐点动态对齐选定对象
   
5. ;;; 特点：
   
6. ;;;   - 支持UCS坐标系
   
7. ;;;   - 支持选择集及块内对象对齐
   
8. ;;;   - 动态预览效果
   
9. ;;;   - 可调整缩放比例
   
10. ;;; ==============================================================
    
11. 
    
12. (vl-load-com)
    
13. 
    
14. (defun c:TT1 (/ *error* olderr osmode ss pt1 el1 e1 p1 p01 pt2 el2 e2 p2 p02 sc
    
15.                 gr last-ent transform-matrix doc)
    
16.   
    
17.   ;; 局部函数：错误处理
    
18.   (defun *error* (msg)
    
19.     (if transform-matrix (apply-transform ss (inverse-matrix transform-matrix)))
    
20.     (if e1 (entdel e1))
    
21.     (if e2 (entdel e2))
    
22.     (command-s ".undo" "e")
    
23.     (command-s ".u")
    
24.     (setvar "osmode" osmode)
    
25.     (setq *error* olderr)
    
26.     (princ (strcat "\n错误: " msg))
    
27.   
    
28.   (setq doc (vla-get-activedocument (vlax-get-acad-object)))
    
29.   ;; 保存原始状态
    
30.   (setq olderr *error*
    
31.         osmode (getvar "osmode")
    
32.         last-ent (entlast))
    
33.   
    
34.   (setvar "osmode" 512) ; 仅捕捉最近点
    
35.   
    
36.   ;; 选择对象
    
37.   (cond
    
38.     ((not (setq ss (ssget (if (ssget "I") "I" "")))
    
39.      (princ "\n未选择对象"))
    
40.     ((not (setq pt1 (getpoint "\n选择参照点: ")))
    
41.      (princ "\n未指定参照点"))
    
42.     ((not (setq el1 (nentselp pt1)))
    
43.      (princ "\n未捕捉到有效实体"))
    
44.     ((not (wcmatch (cdr (assoc 0 (entget (car el1)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))
    
45.      (princ "\n参照实体类型不支持"))
    
46.     (t
    
47.      (command-s ".undo" "be")
    
48.      
    
49.      ;; 创建临时参照实体
    
50.      (setq e1 (create-temp-entity el1)
    
51.            p1 (vlax-curve-getclosestpointto e1 (trans (cadr el1) 1 0))
    
52.            p01 (get-curve-endpoint e1 p1))
    
53.      
    
54.      ;; 清理临时实体
    
55.      (clean-temp-entities last-ent)
    
56.      
    
57.      (princ "\n选对齐点，点击确认<退出>: (S-缩放比例/X-退出)")
    
58.      (setq sc 1.0) ; 默认缩放系数
    
59.      (setq transform-matrix nil)
    
60.      
    
61.      ;; 主循环 - 动态对齐
    
62.      (while (and (setq gr (grread t 15 2))
    
63.                  (not (member (car gr) '(3 11 13 25)))
    
64.       
    
65.        (cond
    
66.          ;; 鼠标移动 - 更新动态对齐
    
67.          ((= (car gr) 5)
    
68.           (setq pt2 (cadr gr))
    
69.           (if (and (not (equal pt2 pt1 0.01))
    
70.                    (setq el2 (nentselp pt2))
    
71.                    (wcmatch (cdr (assoc 0 (entget (car el2)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))
    
72.             (progn
    
73.               ;; 创建临时目标实体
    
74.               (if e2 (entdel e2))
    
75.               (setq e2 (create-temp-entity el2)
    
76.                     p2 (vlax-curve-getclosestpointto e2 (trans (cadr el2) 1 0))
    
77.                     p02 (get-curve-endpoint e2 p2))
    
78.               
    
79.               ;; 计算变换矩阵
    
80.               (setq transform-matrix
    
81.                     (calculate-transform-matrix p01 p1 p02 p2 sc))
    
82.               
    
83.               ;; 应用变换
    
84.               (if transform-matrix
    
85.                 (apply-transform ss transform-matrix))
    
86.               
    
87.               ;; 清理临时实体
    
88.               (if e2 (entdel e2) (setq e2 nil)))
    
89.           (if transform-matrix
    
90.             (apply-transform ss (inverse-matrix transform-matrix))))
    
91.          
    
92.          ;; 键盘输入
    
93.          ((= (car gr) 2)
    
94.           (cond
    
95.             ((or (= (cadr gr) 83) (= (cadr gr) 115)) ; S或s
    
96.              (if (setq tmp (getdist (strcat "\n输入缩放系数<" (rtos sc 2 2) ">: ")))
    
97.                (setq sc tmp)))
    
98.             ((or (= (cadr gr) 88) (= (cadr gr) 120)) ; X或x
    
99.              (exit))))
    
100.        )
     
101.      )
     
102.     )
     
103.   
     
104.   ;; 恢复原始状态
     
105.   (if e1 (entdel e1))
     
106.   (if e2 (entdel e2))
     
107.   (setvar "osmode" osmode)
     
108.   (command-s ".undo" "e")
     
109.   (princ)
     
110. )
     
111. 
     
112. ;; ==============================================
     
113. ;;               工具函数
     
114. ;; ==============================================
     
115. 
     
116. ;; 创建临时实体用于对齐参考
     
117. (defun create-temp-entity (el / ent)
     
118.   (if (= (length el) 2)
     
119.     (car el)
     
120.     (progn
     
121.       (setq ent (entmakex (entget (car el))))
     
122.       (vla-transformby (vlax-ename->vla-object ent) (vlax-tmatrix (caddr el)))
     
123.       ent)))
     
124. 
     
125. ;; 清理临时实体
     
126. (defun clean-temp-entities (last-ent / ent)
     
127.   (while (and (setq ent (entnext last-ent))
     
128.     (entdel ent)
     
129.     (setq last-ent ent)))
     
130. 
     
131. ;; 获取曲线的端点(最近顶点)
     
132. (defun get-curve-endpoint (e p / param typ dist total)
     
133.   (setq param (vlax-curve-getparamatpoint e p)
     
134.         typ (cdr (assoc 0 (entget e)))
     
135.         dist (vlax-curve-getdistatpoint e p)
     
136.         total (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
     
137.   
     
138.   (cond
     
139.     ((wcmatch typ "*POLYLINE")
     
140.      (vlax-curve-getpointatparam e (fix (+ param 0.5))))
     
141.     (t
     
142.      (if (< dist (/ total 2.0))
     
143.        (vlax-curve-getstartpoint e)
     
144.        (vlax-curve-getendpoint e)))))
     
145. 
     
146. ;; 计算变换矩阵
     
147. (defun calculate-transform-matrix (p01 p1 p02 p2 sc / ang)
     
148.   (setq ang (- (angle p02 p2) (angle p01 p1)))
     
149.   
     
150.   (matrix-multiply
     
151.     (list
     
152.       (translation-matrix (mapcar '- p01))
     
153.       (scale-matrix sc)
     
154.       (rotation-z-matrix ang)
     
155.       (translation-matrix p02)))
     
156. 
     
157. ;; 应用变换矩阵到选择集
     
158. (defun apply-transform (ss mat / i ent obj)
     
159.   (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
     
160.     (vla-transformby obj (vlax-tmatrix mat))))
     
161. 
     
162. ;; 矩阵求逆
     
163. (defun inverse-matrix (mat)
     
164.   (vlax-tmatrix (vlax-matrix-inverse (vlax-tmatrix mat))))
     
165. 
     
166. ;; ==============================================
     
167. ;;               矩阵操作函数
     
168. ;; ==============================================
     
169. 
     
170. ;; 平移矩阵
     
171. (defun translation-matrix (p)
     
172.   (list (list 1.0 0.0 0.0 (car p))
     
173.         (list 0.0 1.0 0.0 (cadr p))
     
174.         (list 0.0 0.0 1.0 (caddr p))
     
175.         '(0.0 0.0 0.0 1.0)))
     
176. 
     
177. ;; 缩放矩阵
     
178. (defun scale-matrix (s)
     
179.   (if (listp s)
     
180.     (list (list (car s) 0.0 0.0 0.0)
     
181.           (list 0.0 (cadr s) 0.0 0.0)
     
182.           (list 0.0 0.0 (caddr s) 0.0)
     
183.           '(0.0 0.0 0.0 1.0))
     
184.     (list (list s 0.0 0.0 0.0)
     
185.           (list 0.0 s 0.0 0.0)
     
186.           (list 0.0 0.0 s 0.0)
     
187.           '(0.0 0.0 0.0 1.0))))
     
188. 
     
189. ;; Z轴旋转矩阵
     
190. (defun rotation-z-matrix (ang)
     
191.   (list (list (cos ang) (- (sin ang)) 0.0 0.0)
     
192.         (list (sin ang) (cos ang) 0.0 0.0)
     
193.         (list 0.0 0.0 1.0 0.0)
     
194.         '(0.0 0.0 0.0 1.0)))
     
195. 
     
196. ;; 矩阵相乘
     
197. (defun matrix-multiply (matrices)
     
198.   (setq matrices (reverse matrices))
     
199.   (apply 'vlax-matrix-multiply matrices))
     
200. 
     
201. (princ "\n动态对齐命令已加载，输入TT1 使用。")
     
202. (princ)

;;; ==============================================================<br /> ;;;                 动态简单对齐<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a> (TT1命令)<br /> ;;; 功能：动态简单对齐(支持UCS,支持选集及块内对齐)，通过参照点和对齐点动态对齐选定对象<br /> ;;; 特点：<br /> ;;;   - 支持UCS坐标系<br /> ;;;   - 支持选择集及块内对象对齐<br /> ;;;   - 动态预览效果<br /> ;;;   - 可调整缩放比例<br /> ;;; ==============================================================<br /> <br /> (vl-load-com)<br /> <br /> (defun c:TT1 (/ *error* olderr osmode ss pt1 el1 e1 p1 p01 pt2 el2 e2 p2 p02 sc<br />                 gr last-ent transform-matrix doc)<br />   <br />   ;; 局部函数：错误处理<br />   (defun *error* (msg)<br />     (if transform-matrix (apply-transform ss (inverse-matrix transform-matrix)))<br />     (if e1 (entdel e1))<br />     (if e2 (entdel e2))<br />     (command-s ".undo" "e")<br />     (command-s ".u")<br />     (setvar "osmode" osmode)<br />     (setq *error* olderr)<br />     (princ (strcat "\n错误: " msg))<br />   <br />   (setq doc (vla-get-activedocument (vlax-get-acad-object)))<br />   ;; 保存原始状态<br />   (setq olderr *error*<br />         osmode (getvar "osmode")<br />         last-ent (entlast))<br />   <br />   (setvar "osmode" 512) ; 仅捕捉最近点<br />   <br />   ;; 选择对象<br />   (cond<br />     ((not (setq ss (ssget (if (ssget "I") "I" "")))<br />      (princ "\n未选择对象"))<br />     ((not (setq pt1 (getpoint "\n选择参照点: ")))<br />      (princ "\n未指定参照点"))<br />     ((not (setq el1 (nentselp pt1)))<br />      (princ "\n未捕捉到有效实体"))<br />     ((not (wcmatch (cdr (assoc 0 (entget (car el1)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))<br />      (princ "\n参照实体类型不支持"))<br />     (t<br />      (command-s ".undo" "be")<br />      <br />      ;; 创建临时参照实体<br />      (setq e1 (create-temp-entity el1)<br />            p1 (vlax-curve-getclosestpointto e1 (trans (cadr el1) 1 0))<br />            p01 (get-curve-endpoint e1 p1))<br />      <br />      ;; 清理临时实体<br />      (clean-temp-entities last-ent)<br />      <br />      (princ "\n选对齐点，点击确认<退出>: (S-缩放比例/X-退出)")<br />      (setq sc 1.0) ; 默认缩放系数<br />      (setq transform-matrix nil)<br />      <br />      ;; 主循环 - 动态对齐<br />      (while (and (setq gr (grread t 15 2))<br />                  (not (member (car gr) '(3 11 13 25)))<br />        <br />        (cond<br />          ;; 鼠标移动 - 更新动态对齐<br />          ((= (car gr) 5)<br />           (setq pt2 (cadr gr))<br />           (if (and (not (equal pt2 pt1 0.01))<br />                    (setq el2 (nentselp pt2))<br />                    (wcmatch (cdr (assoc 0 (entget (car el2)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))<br />             (progn<br />               ;; 创建临时目标实体<br />               (if e2 (entdel e2))<br />               (setq e2 (create-temp-entity el2)<br />                     p2 (vlax-curve-getclosestpointto e2 (trans (cadr el2) 1 0))<br />                     p02 (get-curve-endpoint e2 p2))<br />               <br />               ;; 计算变换矩阵<br />               (setq transform-matrix <br />                     (calculate-transform-matrix p01 p1 p02 p2 sc))<br />               <br />               ;; 应用变换<br />               (if transform-matrix<br />                 (apply-transform ss transform-matrix))<br />               <br />               ;; 清理临时实体<br />               (if e2 (entdel e2) (setq e2 nil)))<br />           (if transform-matrix<br />             (apply-transform ss (inverse-matrix transform-matrix))))<br />          <br />          ;; 键盘输入<br />          ((= (car gr) 2)<br />           (cond<br />             ((or (= (cadr gr) 83) (= (cadr gr) 115)) ; S或s<br />              (if (setq tmp (getdist (strcat "\n输入缩放系数<" (rtos sc 2 2) ">: ")))<br />                (setq sc tmp)))<br />             ((or (= (cadr gr) 88) (= (cadr gr) 120)) ; X或x<br />              (exit))))<br />        )<br />      )<br />     )<br />   <br />   ;; 恢复原始状态<br />   (if e1 (entdel e1))<br />   (if e2 (entdel e2))<br />   (setvar "osmode" osmode)<br />   (command-s ".undo" "e")<br />   (princ)<br /> )<br /> <br /> ;; ==============================================<br /> ;;               工具函数<br /> ;; ==============================================<br /> <br /> ;; 创建临时实体用于对齐参考<br /> (defun create-temp-entity (el / ent)<br />   (if (= (length el) 2)<br />     (car el)<br />     (progn<br />       (setq ent (entmakex (entget (car el))))<br />       (vla-transformby (vlax-ename->vla-object ent) (vlax-tmatrix (caddr el)))<br />       ent)))<br /> <br /> ;; 清理临时实体<br /> (defun clean-temp-entities (last-ent / ent)<br />   (while (and (setq ent (entnext last-ent))<br />     (entdel ent)<br />     (setq last-ent ent)))<br /> <br /> ;; 获取曲线的端点(最近顶点)<br /> (defun get-curve-endpoint (e p / param typ dist total)<br />   (setq param (vlax-curve-getparamatpoint e p)<br />         typ (cdr (assoc 0 (entget e)))<br />         dist (vlax-curve-getdistatpoint e p)<br />         total (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))<br />   <br />   (cond<br />     ((wcmatch typ "*POLYLINE")<br />      (vlax-curve-getpointatparam e (fix (+ param 0.5))))<br />     (t<br />      (if (< dist (/ total 2.0))<br />        (vlax-curve-getstartpoint e)<br />        (vlax-curve-getendpoint e)))))<br /> <br /> ;; 计算变换矩阵<br /> (defun calculate-transform-matrix (p01 p1 p02 p2 sc / ang)<br />   (setq ang (- (angle p02 p2) (angle p01 p1)))<br />   <br />   (matrix-multiply<br />     (list<br />       (translation-matrix (mapcar '- p01))<br />       (scale-matrix sc)<br />       (rotation-z-matrix ang)<br />       (translation-matrix p02)))<br /> <br /> ;; 应用变换矩阵到选择集<br /> (defun apply-transform (ss mat / i ent obj)<br />   (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))<br />     (vla-transformby obj (vlax-tmatrix mat))))<br /> <br /> ;; 矩阵求逆<br /> (defun inverse-matrix (mat)<br />   (vlax-tmatrix (vlax-matrix-inverse (vlax-tmatrix mat))))<br /> <br /> ;; ==============================================<br /> ;;               矩阵操作函数<br /> ;; ==============================================<br /> <br /> ;; 平移矩阵<br /> (defun translation-matrix (p)<br />   (list (list 1.0 0.0 0.0 (car p))<br />         (list 0.0 1.0 0.0 (cadr p))<br />         (list 0.0 0.0 1.0 (caddr p))<br />         '(0.0 0.0 0.0 1.0)))<br /> <br /> ;; 缩放矩阵<br /> (defun scale-matrix (s)<br />   (if (listp s)<br />     (list (list (car s) 0.0 0.0 0.0)<br />           (list 0.0 (cadr s) 0.0 0.0)<br />           (list 0.0 0.0 (caddr s) 0.0)<br />           '(0.0 0.0 0.0 1.0))<br />     (list (list s 0.0 0.0 0.0)<br />           (list 0.0 s 0.0 0.0)<br />           (list 0.0 0.0 s 0.0)<br />           '(0.0 0.0 0.0 1.0))))<br /> <br /> ;; Z轴旋转矩阵<br /> (defun rotation-z-matrix (ang)<br />   (list (list (cos ang) (- (sin ang)) 0.0 0.0)<br />         (list (sin ang) (cos ang) 0.0 0.0)<br />         (list 0.0 0.0 1.0 0.0)<br />         '(0.0 0.0 0.0 1.0)))<br /> <br /> ;; 矩阵相乘<br /> (defun matrix-multiply (matrices)<br />   (setq matrices (reverse matrices))<br />   (apply 'vlax-matrix-multiply matrices))<br /> <br /> (princ "\n动态对齐命令已加载，输入TT1 使用。")<br /> (princ)

czb203

谢谢大佬的分享

tranque

czb203 发表于 2025-6-13 15:48
谢谢大佬的分享

水帖子还得是你

guosheyang

动态预览效果是啥效果？  cad本身的 al命令是不是动态预览效果的？块儿内要素对齐  用-refedit 是最简单的， 块儿内参照编辑是不支持ucs的   需要 先转为世界坐标系    参照编辑 完成后 还回 ucs，  如果不用-refedit,  可以 先将块儿炸开  对齐操作完成后   再将 要素放回到块儿内 ，我想到的有这两种方法，不知还有无其他方法  

332398174

czb203 发表于 2025-6-13 15:48
谢谢大佬的分享

我草，天天看到你水贴