明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 811|回复: 5

[提问] 求助调试一下这个简单对齐的程序

[复制链接]
发表于 2025-6-13 13:27:06 | 显示全部楼层 |阅读模式
这个简单对齐的程序实现的功能:动态简单对齐(支持UCS,支持选集及块内对齐),通过参照点和对齐点动态对齐选定对象,特点:1.支持UCS坐标系,2.支持选择集及块内对象对齐,3.动态预览效果,4.可调整缩放比例
但是在cad2020下一直报错,求大佬帮忙调试一下。


  1. ;;; ==============================================================
  2. ;;;                 动态简单对齐工具 (TT1命令)
  3. ;;; 功能:动态简单对齐(支持UCS,支持选集及块内对齐),通过参照点和对齐点动态对齐选定对象
  4. ;;; 特点:
  5. ;;;   - 支持UCS坐标系
  6. ;;;   - 支持选择集及块内对象对齐
  7. ;;;   - 动态预览效果
  8. ;;;   - 可调整缩放比例
  9. ;;; ==============================================================

  10. (vl-load-com)

  11. (defun c:TT1 (/ *error* olderr osmode ss pt1 el1 e1 p1 p01 pt2 el2 e2 p2 p02 sc
  12.                 gr last-ent transform-matrix doc)
  13.   
  14.   ;; 局部函数:错误处理
  15.   (defun *error* (msg)
  16.     (if transform-matrix (apply-transform ss (inverse-matrix transform-matrix)))
  17.     (if e1 (entdel e1))
  18.     (if e2 (entdel e2))
  19.     (command-s ".undo" "e")
  20.     (command-s ".u")
  21.     (setvar "osmode" osmode)
  22.     (setq *error* olderr)
  23.     (princ (strcat "\n错误: " msg))
  24.   
  25.   (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  26.   ;; 保存原始状态
  27.   (setq olderr *error*
  28.         osmode (getvar "osmode")
  29.         last-ent (entlast))
  30.   
  31.   (setvar "osmode" 512) ; 仅捕捉最近点
  32.   
  33.   ;; 选择对象
  34.   (cond
  35.     ((not (setq ss (ssget (if (ssget "I") "I" "")))
  36.      (princ "\n未选择对象"))
  37.     ((not (setq pt1 (getpoint "\n选择参照点: ")))
  38.      (princ "\n未指定参照点"))
  39.     ((not (setq el1 (nentselp pt1)))
  40.      (princ "\n未捕捉到有效实体"))
  41.     ((not (wcmatch (cdr (assoc 0 (entget (car el1)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))
  42.      (princ "\n参照实体类型不支持"))
  43.     (t
  44.      (command-s ".undo" "be")
  45.      
  46.      ;; 创建临时参照实体
  47.      (setq e1 (create-temp-entity el1)
  48.            p1 (vlax-curve-getclosestpointto e1 (trans (cadr el1) 1 0))
  49.            p01 (get-curve-endpoint e1 p1))
  50.      
  51.      ;; 清理临时实体
  52.      (clean-temp-entities last-ent)
  53.      
  54.      (princ "\n选对齐点,点击确认<退出>: (S-缩放比例/X-退出)")
  55.      (setq sc 1.0) ; 默认缩放系数
  56.      (setq transform-matrix nil)
  57.      
  58.      ;; 主循环 - 动态对齐
  59.      (while (and (setq gr (grread t 15 2))
  60.                  (not (member (car gr) '(3 11 13 25)))
  61.       
  62.        (cond
  63.          ;; 鼠标移动 - 更新动态对齐
  64.          ((= (car gr) 5)
  65.           (setq pt2 (cadr gr))
  66.           (if (and (not (equal pt2 pt1 0.01))
  67.                    (setq el2 (nentselp pt2))
  68.                    (wcmatch (cdr (assoc 0 (entget (car el2)))) "*LINE,ELLIPSE,ARC,CIRCLE,RAY"))
  69.             (progn
  70.               ;; 创建临时目标实体
  71.               (if e2 (entdel e2))
  72.               (setq e2 (create-temp-entity el2)
  73.                     p2 (vlax-curve-getclosestpointto e2 (trans (cadr el2) 1 0))
  74.                     p02 (get-curve-endpoint e2 p2))
  75.               
  76.               ;; 计算变换矩阵
  77.               (setq transform-matrix
  78.                     (calculate-transform-matrix p01 p1 p02 p2 sc))
  79.               
  80.               ;; 应用变换
  81.               (if transform-matrix
  82.                 (apply-transform ss transform-matrix))
  83.               
  84.               ;; 清理临时实体
  85.               (if e2 (entdel e2) (setq e2 nil)))
  86.           (if transform-matrix
  87.             (apply-transform ss (inverse-matrix transform-matrix))))
  88.          
  89.          ;; 键盘输入
  90.          ((= (car gr) 2)
  91.           (cond
  92.             ((or (= (cadr gr) 83) (= (cadr gr) 115)) ; S或s
  93.              (if (setq tmp (getdist (strcat "\n输入缩放系数<" (rtos sc 2 2) ">: ")))
  94.                (setq sc tmp)))
  95.             ((or (= (cadr gr) 88) (= (cadr gr) 120)) ; X或x
  96.              (exit))))
  97.        )
  98.      )
  99.     )
  100.   
  101.   ;; 恢复原始状态
  102.   (if e1 (entdel e1))
  103.   (if e2 (entdel e2))
  104.   (setvar "osmode" osmode)
  105.   (command-s ".undo" "e")
  106.   (princ)
  107. )

  108. ;; ==============================================
  109. ;;               工具函数
  110. ;; ==============================================

  111. ;; 创建临时实体用于对齐参考
  112. (defun create-temp-entity (el / ent)
  113.   (if (= (length el) 2)
  114.     (car el)
  115.     (progn
  116.       (setq ent (entmakex (entget (car el))))
  117.       (vla-transformby (vlax-ename->vla-object ent) (vlax-tmatrix (caddr el)))
  118.       ent)))

  119. ;; 清理临时实体
  120. (defun clean-temp-entities (last-ent / ent)
  121.   (while (and (setq ent (entnext last-ent))
  122.     (entdel ent)
  123.     (setq last-ent ent)))

  124. ;; 获取曲线的端点(最近顶点)
  125. (defun get-curve-endpoint (e p / param typ dist total)
  126.   (setq param (vlax-curve-getparamatpoint e p)
  127.         typ (cdr (assoc 0 (entget e)))
  128.         dist (vlax-curve-getdistatpoint e p)
  129.         total (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
  130.   
  131.   (cond
  132.     ((wcmatch typ "*POLYLINE")
  133.      (vlax-curve-getpointatparam e (fix (+ param 0.5))))
  134.     (t
  135.      (if (< dist (/ total 2.0))
  136.        (vlax-curve-getstartpoint e)
  137.        (vlax-curve-getendpoint e)))))

  138. ;; 计算变换矩阵
  139. (defun calculate-transform-matrix (p01 p1 p02 p2 sc / ang)
  140.   (setq ang (- (angle p02 p2) (angle p01 p1)))
  141.   
  142.   (matrix-multiply
  143.     (list
  144.       (translation-matrix (mapcar '- p01))
  145.       (scale-matrix sc)
  146.       (rotation-z-matrix ang)
  147.       (translation-matrix p02)))

  148. ;; 应用变换矩阵到选择集
  149. (defun apply-transform (ss mat / i ent obj)
  150.   (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
  151.     (vla-transformby obj (vlax-tmatrix mat))))

  152. ;; 矩阵求逆
  153. (defun inverse-matrix (mat)
  154.   (vlax-tmatrix (vlax-matrix-inverse (vlax-tmatrix mat))))

  155. ;; ==============================================
  156. ;;               矩阵操作函数
  157. ;; ==============================================

  158. ;; 平移矩阵
  159. (defun translation-matrix (p)
  160.   (list (list 1.0 0.0 0.0 (car p))
  161.         (list 0.0 1.0 0.0 (cadr p))
  162.         (list 0.0 0.0 1.0 (caddr p))
  163.         '(0.0 0.0 0.0 1.0)))

  164. ;; 缩放矩阵
  165. (defun scale-matrix (s)
  166.   (if (listp s)
  167.     (list (list (car s) 0.0 0.0 0.0)
  168.           (list 0.0 (cadr s) 0.0 0.0)
  169.           (list 0.0 0.0 (caddr s) 0.0)
  170.           '(0.0 0.0 0.0 1.0))
  171.     (list (list s 0.0 0.0 0.0)
  172.           (list 0.0 s 0.0 0.0)
  173.           (list 0.0 0.0 s 0.0)
  174.           '(0.0 0.0 0.0 1.0))))

  175. ;; Z轴旋转矩阵
  176. (defun rotation-z-matrix (ang)
  177.   (list (list (cos ang) (- (sin ang)) 0.0 0.0)
  178.         (list (sin ang) (cos ang) 0.0 0.0)
  179.         (list 0.0 0.0 1.0 0.0)
  180.         '(0.0 0.0 0.0 1.0)))

  181. ;; 矩阵相乘
  182. (defun matrix-multiply (matrices)
  183.   (setq matrices (reverse matrices))
  184.   (apply 'vlax-matrix-multiply matrices))

  185. (princ "\n动态对齐命令已加载,输入TT1 使用。")
  186. (princ)


"觉得好,就打赏"
还没有人打赏,支持一下
回复

使用道具 举报

发表于 2025-6-13 15:48:42 | 显示全部楼层
谢谢大佬的分享
回复 支持 1 反对 0

使用道具 举报

发表于 2025-6-13 16:56:26 | 显示全部楼层
czb203 发表于 2025-6-13 15:48
谢谢大佬的分享

水帖子还得是你
回复 支持 1 反对 0

使用道具 举报

发表于 2025-6-14 16:58:57 | 显示全部楼层
动态预览效果是啥效果?  cad本身的 al命令是不是动态预览效果的?块儿内要素对齐  用-refedit 是最简单的, 块儿内参照编辑是不支持ucs的   需要 先转为世界坐标系    参照编辑 完成后 还回 ucs,  如果不用-refedit,  可以 先将块儿炸开  对齐操作完成后   再将 要素放回到块儿内 ,我想到的有这两种方法,不知还有无其他方法  
回复 支持 反对

使用道具 举报

发表于 2025-6-14 17:40:39 | 显示全部楼层
czb203 发表于 2025-6-13 15:48
谢谢大佬的分享

我草,天天看到你水贴

点评

好巧啊,你也在,我天天都在,论坛是我家,我没事就来逛逛  发表于 2025-6-14 18:01
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2025-7-14 16:40 , Processed in 0.196103 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表