自动标注命令 还可以改进 请各位大佬指教 刚学习LiSP（新人帖）

敖沧海

2. 
   
3. (defun c:DBB( / *error* ssBase ssIntersect lstBaseEnts lstIntersectEnts lstLines lstDims)
   
4.     (vl-load-com)
   
5.    
   
6.     (defun *error* (msg)
   
7.         (if (and lstLines (vlax-ldata-get "DimLines" "CreatedLines"))
   
8.             (foreach ent (vlax-ldata-get "DimLines" "CreatedLines") (entdel ent))
   
9.         )
   
10.         (if (and lstDims (vlax-ldata-get "DimLines" "CreatedDims"))
    
11.             (foreach ent (vlax-ldata-get "DimLines" "CreatedDims") (entdel ent))
    
12.         )
    
13.         (princ "\nError: ")
    
14.         (princ msg)
    
15.         (princ)
    
16.     )
    
17. 
    
18.     ;; 选择基准线
    
19.     ;(princ "\n选择基准线: ")
    
20.     ;(setq ssBase (car (entsel "\n选择基准线: ")))
    
21.   ;  (if (not (member (cdr (assoc 0 (entget ssBase))) '("LINE" "LWPOLYLINE")))
    
22.   ;      (progn (alert "必须选择直线或轻量多段线！") (exit)))
    
23.   
    
24.     (if (not (setq ssBase (ssget  '((0 . "LINE,LWPOLYLINE")))))
    
25.       (progn (alert "未选择基准线！") (exit))
    
26.       (princ "\n--------已选择基准线:-------- ")
    
27.     )
    
28. 
    
29.     ;; 选择相交线
    
30.     ;(princ "\n选择相交线: ")
    
31.     ;(setq ssIntersect (car (entsel "\n未选择相交线: ")))
    
32.   ;  (if (not (member (cdr (assoc 0 (entget ssIntersect))) '("LINE" "LWPOLYLINE")))
    
33.   ;      (progn (alert "未选择相交线！") (exit)))
    
34.     (if (not (setq ssIntersect (ssget '((0 . "LINE,LWPOLYLINE")))))
    
35.         (progn (alert "未选择相交线！") (exit))
    
36.       (princ "\n--------已选择相交线:-------- ")
    
37.     )
    
38. 
    
39.     ;; 转换选择集为实体列表
    
40.    
    
41.     (setq lstBaseEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBase))))
    
42.     (setq lstIntersectEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssIntersect))))
    
43. 
    
44.     ;; 步骤1：创建连接线
    
45.     (setq lstLines (CreateConnectionLines lstBaseEnts lstIntersectEnts))
    
46.     (vlax-ldata-put "DimLines" "CreatedLines" lstLines)
    
47. 
    
48.     ;; 步骤2：创建标注
    
49.     (setq lstDims (CreateAlignDims lstLines))
    
50.     (vlax-ldata-put "DimLines" "CreatedDims" lstDims)
    
51. 
    
52.     ;; 步骤3：解除标注关联
    
53.     (DisassociateDims lstDims)
    
54. 
    
55.     ;; 步骤4：删除临时线
    
56.     (foreach ent lstLines (entdel ent))
    
57.    
    
58.     ;; 步骤5：删除零值标注
    
59.     (foreach dim lstDims
    
60.         (if (ZeroDimCheck dim)
    
61.             (entdel dim)
    
62.         )
    
63.     )
    
64.   
    
65.     (princ)
    
66. )
    
67. 
    
68. 
    
69. 
    
70. ;; 创建连接线函数
    
71. (defun CreateConnectionLines (baseEnts intersectEnts / lstLines)
    
72.     (setq lstLines '())
    
73.     (foreach baseEnt baseEnts
    
74.         (setq lstPoints (GetIntersectionPoints baseEnt intersectEnts))
    
75.         (if (> (length lstPoints) 1)
    
76.             (progn
    
77.                 (setq lstPoints (SortPointsOnCurve baseEnt lstPoints))
    
78.                 (setq lstLines (append (CreateLinesBetweenPoints lstPoints) lstLines))
    
79.             )
    
80.         )
    
81.     )
    
82.     lstLines
    
83. )
    
84. 
    
85. ;; 获取所有交点
    
86. ;; 获取所有交点（修正后的版本）
    
87. (defun GetIntersectionPoints (baseEnt others / lstPoints pts3d)
    
88.     (setq lstPoints '())
    
89.     (foreach otherEnt others
    
90.         (setq pts (vlax-invoke (vlax-ename->vla-object baseEnt) 'IntersectWith
    
91.                                (vlax-ename->vla-object otherEnt) acExtendNone))
    
92.         ;; 将三维坐标点列表转换为二维点列表
    
93.         (if (> (length pts) 2)
    
94.             (progn
    
95.                 ;; 新增加的三维点分组处理
    
96.                 (setq pts3d '())
    
97.                 (repeat (/ (length pts) 3) ; 确保按三个元素分组
    
98.                     (setq pts3d (cons (list (car pts) (cadr pts) (caddr pts)) pts3d))
    
99.                     (setq pts (cdddr pts))
    
100.                 )
     
101.                 ;; 转换为二维点并过滤无效点
     
102.                 (setq pts2d (mapcar '(lambda (pt) (list (car pt) (cadr pt))) (reverse pts3d)))
     
103.                 (setq lstPoints (append pts2d lstPoints))
     
104.             )
     
105.         )
     
106.     )
     
107.     ;; 过滤不在基准线上的点
     
108.     (vl-remove-if-not '(lambda (pt) (vlax-curve-getParamAtPoint baseEnt pt)) lstPoints)
     
109. )
     
110. 
     
111. ;; 按曲线参数排序点
     
112. (defun SortPointsOnCurve (ent pts)
     
113.     (vl-sort pts '(lambda (a b) (< (vlax-curve-getParamAtPoint ent a) (vlax-curve-getParamAtPoint ent b))))
     
114. )
     
115. 
     
116. ;; 创建点间连线
     
117. (defun CreateLinesBetweenPoints (pts / lstLines prev)
     
118.     (setq lstLines '() prev (car pts))
     
119.     (foreach pt (cdr pts)
     
120.         (setq ent (entmakex (list '(0 . "LINE") (cons 10 prev) (cons 11 pt))))
     
121.         (if ent (setq lstLines (cons ent lstLines)))
     
122.         (setq prev pt)
     
123.     )
     
124.     lstLines
     
125. )
     
126. 
     
127. ;; 创建对齐标注
     
128. (defun CreateAlignDims (lines / lstDims)
     
129.     (setq lstDims '())
     
130.     ;; 用户选择侧边
     
131.     (initget "Up Down")
     
132.     (setq side (getkword "\n选择标注侧边[上(Up)/下(Down)]: "))
     
133.   
     
134.     (foreach line lines
     
135.         (setq obj (vlax-ename->vla-object line))
     
136.         (setq p1 (vlax-get obj 'StartPoint))
     
137.         (setq p2 (vlax-get obj 'EndPoint))
     
138.         
     
139.         ;; 计算偏移方向
     
140.         (setq ang (angle p1 p2))
     
141.         (setq offsetPt1 (polar p1 (+ ang (/ pi 2)) 500))
     
142.         (setq offsetPt2 (polar p1 (- ang (/ pi 2)) 500))
     
143.         
     
144.         
     
145.         
     
146.         ;; 创建标注
     
147.         (if (eq side "Up")
     
148.             (command "_.dimaligned" "_non" p1 "_non" p2 "_non" offsetPt1)
     
149.             (command "_.dimaligned" "_non" p1 "_non" p2 "_non" offsetPt2)
     
150.         )
     
151.         (setq lstDims (cons (entlast) lstDims))
     
152.     )
     
153.     lstDims
     
154. )
     
155. 
     
156. ;; 解除标注关联
     
157. (defun DisassociateDims (dims)
     
158.     (command "_.dimdisassociate" (ssget "_X" '((0 . "DIMENSION"))))
     
159. )
     
160. 
     
161. ;;零值判断
     
162. (defun ZeroDimCheck (dim)
     
163.     (equal
     
164.       (cdr (assoc 42 (entget dim)))
     
165.       0.0
     
166.       1e-6) ; 带容差的零值判断
     
167. )
     
168. (princ "请输入DBB调用函数！")

<br /> (defun c:DBB( / *error* ssBase ssIntersect lstBaseEnts lstIntersectEnts lstLines lstDims)<br />     (vl-load-com)<br />     <br />     (defun *error* (msg)<br />         (if (and lstLines (vlax-ldata-get "DimLines" "CreatedLines"))<br />             (foreach ent (vlax-ldata-get "DimLines" "CreatedLines") (entdel ent))<br />         )<br />         (if (and lstDims (vlax-ldata-get "DimLines" "CreatedDims"))<br />             (foreach ent (vlax-ldata-get "DimLines" "CreatedDims") (entdel ent))<br />         )<br />         (princ "\nError: ")<br />         (princ msg)<br />         (princ)<br />     )<br /> <br />     ;; 选择基准线<br />     ;(princ "\n选择基准线: ")<br />     ;(setq ssBase (car (entsel "\n选择基准线: ")))<br />   ;  (if (not (member (cdr (assoc 0 (entget ssBase))) '("LINE" "LWPOLYLINE")))<br />   ;      (progn (alert "必须选择直线或轻量多段线！") (exit)))<br />   <br />     (if (not (setq ssBase (ssget  '((0 . "LINE,LWPOLYLINE")))))<br />       (progn (alert "未选择基准线！") (exit))<br />       (princ "\n--------已选择基准线:-------- ")<br />     )<br /> <br />     ;; 选择相交线<br />     ;(princ "\n选择相交线: ")<br />     ;(setq ssIntersect (car (entsel "\n未选择相交线: ")))<br />   ;  (if (not (member (cdr (assoc 0 (entget ssIntersect))) '("LINE" "LWPOLYLINE")))<br />   ;      (progn (alert "未选择相交线！") (exit)))<br />     (if (not (setq ssIntersect (ssget '((0 . "LINE,LWPOLYLINE")))))<br />         (progn (alert "未选择相交线！") (exit))<br />       (princ "\n--------已选择相交线:-------- ")<br />     )<br /> <br />     ;; 转换选择集为实体列表<br />     <br />     (setq lstBaseEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBase))))<br />     (setq lstIntersectEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssIntersect))))<br /> <br />     ;; 步骤1：创建连接线<br />     (setq lstLines (CreateConnectionLines lstBaseEnts lstIntersectEnts))<br />     (vlax-ldata-put "DimLines" "CreatedLines" lstLines)<br /> <br />     ;; 步骤2：创建标注<br />     (setq lstDims (CreateAlignDims lstLines))<br />     (vlax-ldata-put "DimLines" "CreatedDims" lstDims)<br /> <br />     ;; 步骤3：解除标注关联<br />     (DisassociateDims lstDims)<br /> <br />     ;; 步骤4：删除临时线<br />     (foreach ent lstLines (entdel ent))<br />     <br />     ;; 步骤5：删除零值标注<br />     (foreach dim lstDims<br />         (if (ZeroDimCheck dim)<br />             (entdel dim)<br />         )<br />     )<br />   <br />     (princ)<br /> )<br /> <br /> <br /> <br /> ;; 创建连接线函数<br /> (defun CreateConnectionLines (baseEnts intersectEnts / lstLines)<br />     (setq lstLines '())<br />     (foreach baseEnt baseEnts<br />         (setq lstPoints (GetIntersectionPoints baseEnt intersectEnts))<br />         (if (> (length lstPoints) 1)<br />             (progn<br />                 (setq lstPoints (SortPointsOnCurve baseEnt lstPoints))<br />                 (setq lstLines (append (CreateLinesBetweenPoints lstPoints) lstLines))<br />             )<br />         )<br />     )<br />     lstLines<br /> )<br /> <br /> ;; 获取所有交点<br /> ;; 获取所有交点（修正后的版本）<br /> (defun GetIntersectionPoints (baseEnt others / lstPoints pts3d)<br />     (setq lstPoints '())<br />     (foreach otherEnt others<br />         (setq pts (vlax-invoke (vlax-ename->vla-object baseEnt) 'IntersectWith <br />                                (vlax-ename->vla-object otherEnt) acExtendNone))<br />         ;; 将三维坐标点列表转换为二维点列表<br />         (if (> (length pts) 2)<br />             (progn<br />                 ;; 新增加的三维点分组处理<br />                 (setq pts3d '())<br />                 (repeat (/ (length pts) 3) ; 确保按三个元素分组<br />                     (setq pts3d (cons (list (car pts) (cadr pts) (caddr pts)) pts3d))<br />                     (setq pts (cdddr pts))<br />                 )<br />                 ;; 转换为二维点并过滤无效点<br />                 (setq pts2d (mapcar '(lambda (pt) (list (car pt) (cadr pt))) (reverse pts3d)))<br />                 (setq lstPoints (append pts2d lstPoints))<br />             )<br />         )<br />     )<br />     ;; 过滤不在基准线上的点<br />     (vl-remove-if-not '(lambda (pt) (vlax-curve-getParamAtPoint baseEnt pt)) lstPoints)<br /> )<br /> <br /> ;; 按曲线参数排序点<br /> (defun SortPointsOnCurve (ent pts)<br />     (vl-sort pts '(lambda (a b) (< (vlax-curve-getParamAtPoint ent a) (vlax-curve-getParamAtPoint ent b))))<br /> )<br /> <br /> ;; 创建点间连线<br /> (defun CreateLinesBetweenPoints (pts / lstLines prev)<br />     (setq lstLines '() prev (car pts))<br />     (foreach pt (cdr pts)<br />         (setq ent (entmakex (list '(0 . "LINE") (cons 10 prev) (cons 11 pt))))<br />         (if ent (setq lstLines (cons ent lstLines)))<br />         (setq prev pt)<br />     )<br />     lstLines<br /> )<br /> <br /> ;; 创建对齐标注<br /> (defun CreateAlignDims (lines / lstDims)<br />     (setq lstDims '())<br />     ;; 用户选择侧边<br />     (initget "Up Down")<br />     (setq side (getkword "\n选择标注侧边[上(Up)/下(Down)]: "))<br />   <br />     (foreach line lines<br />         (setq obj (vlax-ename->vla-object line))<br />         (setq p1 (vlax-get obj 'StartPoint))<br />         (setq p2 (vlax-get obj 'EndPoint))<br />         <br />         ;; 计算偏移方向<br />         (setq ang (angle p1 p2))<br />         (setq offsetPt1 (polar p1 (+ ang (/ pi 2)) 500))<br />         (setq offsetPt2 (polar p1 (- ang (/ pi 2)) 500))<br />         <br />         <br />         <br />         ;; 创建标注<br />         (if (eq side "Up")<br />             (command "_.dimaligned" "_non" p1 "_non" p2 "_non" offsetPt1)<br />             (command "_.dimaligned" "_non" p1 "_non" p2 "_non" offsetPt2)<br />         )<br />         (setq lstDims (cons (entlast) lstDims))<br />     )<br />     lstDims<br /> )<br /> <br /> ;; 解除标注关联<br /> (defun DisassociateDims (dims)<br />     (command "_.dimdisassociate" (ssget "_X" '((0 . "DIMENSION"))))<br /> )<br /> <br /> ;;零值判断<br /> (defun ZeroDimCheck (dim)<br />     (equal <br />       (cdr (assoc 42 (entget dim)))<br />       0.0 <br />       1e-6) ; 带容差的零值判断<br /> )<br /> (princ "请输入DBB调用函数！")

敖沧海

zm880928 发表于 2025-6-11 19:12
AI写的吧

是的  AI写的  自己也调了一下

zm880928

AI写的吧

土土木木人

同行啊