一个简化版本的图元坐标值圆整程序，源码奉献

vectra

看到highflybir这个非常有创意的程序
[【高飞鸟】] 【飞鸟集】数据取整（更新至2012.6）http://bbs.mjtd.com/thread-86961-1-1.html

心想，符合CAD编程规则的图元，用作坐标的组码值是有一定要求的，所以应该可以用很简单统一的代码实现，于是有了下面这个版本的数据取整程序。理论上应该支持各种已知或未知的图元类型。

highflybir的代码没有深入地看，可能各自对基点和容差的理解、实现各不相同。

在我的版本里，圆整值的含义是：坐标各分量只能是圆整值的整数倍，和“标注舍入”的实现类似。当然，这个简化版本在可靠性和错误处理上要弱一点，而且我这里没有天正或其它有自定义实体的软件，因此也没有办法对自定义的实体进行测试，欢迎大家测试反馈。

1. (vl-load-com)
   
2. 
   
3. (setq *tolerance* 1)
   
4. 
   
5. (defun ceiling (n tor)
   
6.   (* (fix (+ 0.5 (/ n tor))) tor)
   
7. )
   
8. 
   
9. (defun c:fix (/ fixpointgroup fixdxf base dxf ent i offset len ss tor)
   
10.   (defun fixpointgroup (p)
    
11.     (mapcar '(lambda (e) (ceiling e *tolerance*)) (mapcar '+ offset p))
    
12.   )
    
13. 
    
14.   (defun fixdxf        (dxf)
    
15.     ;; 见 DXF 参考 > DXF 格式 > 组码值类型。10-39 双精度三维点值
    
16.     ;; 测试中发现部分 3x 组码并非点，安全起见仅处理 10-14 常用表示点的组码值
    
17.     (setq dxf (mapcar '(lambda (e)
    
18.                          (if (and (>= (car e) 10) (<= (car e) 14))
    
19.                            (cons (car e) (fixpointgroup (cdr e)))
    
20.                            e
    
21.                          )
    
22.                        )
    
23.                       dxf
    
24.               )
    
25.     )
    
26.     (entmod dxf)
    
27.   )
    
28. 
    
29.   (setq ss (ssget))
    
30.   (if ss
    
31.     (progn
    
32.       (setq base (getpoint (strcat "\n指定修正基点:"))) ;_ 基点意在圆整坐标时最小化图元相对位置改变
    
33.       (if (null base)
    
34.         (vl-exit-with-value 1)
    
35.       )
    
36. 
    
37.       (initget 6)
    
38.       (setq tor (getreal (strcat "\n请输入坐标圆整值: <" (rtos *tolerance* 2 3) ">")))
    
39.       (if tor
    
40.         (setq *tolerance* tor)
    
41.       )
    
42. 
    
43.       (setq offset (mapcar '- (mapcar '(lambda (e) (ceiling e *tolerance*)) base) base))
    
44. 
    
45.       (setq len        (sslength ss)
    
46.             i        0
    
47.       )
    
48.       (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
    
49. 
    
50.       (repeat len
    
51.         (setq ent (ssname ss i)
    
52.               dxf (entget ent)
    
53.         )
    
54. 
    
55.         (cond
    
56.           ((= "POLYLINE" (cdr (assoc 0 dxf)))
    
57.            (setq ent (entnext ent))
    
58.            (while (/= (cdr (assoc 0 (setq dxf (entget ent)))) "SEQEND")
    
59.              (fixdxf dxf)
    
60.              (setq ent (entnext ent))
    
61.            )
    
62.           )
    
63. 
    
64.           ;; TODO: 增加其它复合对象处理
    
65. 
    
66.           ;; 其它类型实体均采用该方法处理
    
67.           (t (fixdxf dxf))
    
68.         )
    
69. 
    
70.         (setq i (1+ i))
    
71.       )
    
72. 
    
73.       (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    
74.     )
    
75.   )
    
76.   (princ)
    
77. )

(vl-load-com)<br /> <br /> (setq *tolerance* 1)<br /> <br /> (defun ceiling (n tor)<br />   (* (fix (+ 0.5 (/ n tor))) tor)<br /> )<br /> <br /> (defun c:fix (/ fixpointgroup fixdxf base dxf ent i offset len ss tor)<br />   (defun fixpointgroup (p)<br />     (mapcar '(lambda (e) (ceiling e *tolerance*)) (mapcar '+ offset p))<br />   )<br /> <br />   (defun fixdxf        (dxf)<br />     ;; 见 DXF 参考 > DXF 格式 > 组码值类型。10-39 双精度三维点值<br />     ;; 测试中发现部分 3x 组码并非点，安全起见仅处理 10-14 常用表示点的组码值<br />     (setq dxf (mapcar '(lambda (e)<br />                          (if (and (>= (car e) 10) (<= (car e) 14))<br />                            (cons (car e) (fixpointgroup (cdr e)))<br />                            e<br />                          )<br />                        )<br />                       dxf<br />               )<br />     )<br />     (entmod dxf)<br />   )<br /> <br />   (setq ss (ssget))<br />   (if ss<br />     (progn<br />       (setq base (getpoint (strcat "\n指定修正基点:"))) ;_ 基点意在圆整坐标时最小化图元相对位置改变<br />       (if (null base)<br />         (vl-exit-with-value 1)<br />       )<br /> <br />       (initget 6)<br />       (setq tor (getreal (strcat "\n请输入坐标圆整值: <" (rtos *tolerance* 2 3) ">")))<br />       (if tor<br />         (setq *tolerance* tor)<br />       )<br /> <br />       (setq offset (mapcar '- (mapcar '(lambda (e) (ceiling e *tolerance*)) base) base))<br /> <br />       (setq len        (sslength ss)<br />             i        0<br />       )<br />       (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))<br /> <br />       (repeat len<br />         (setq ent (ssname ss i)<br />               dxf (entget ent)<br />         )<br /> <br />         (cond<br />           ((= "POLYLINE" (cdr (assoc 0 dxf)))<br />            (setq ent (entnext ent))<br />            (while (/= (cdr (assoc 0 (setq dxf (entget ent)))) "SEQEND")<br />              (fixdxf dxf)<br />              (setq ent (entnext ent))<br />            )<br />           )<br /> <br />           ;; TODO: 增加其它复合对象处理<br /> <br />           ;; 其它类型实体均采用该方法处理<br />           (t (fixdxf dxf))<br />         )<br /> <br />         (setq i (1+ i))<br />       )<br /> <br />       (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))<br />     )<br />   )<br />   (princ)<br /> )

sicky111

支持源码。

USER2128

支持楼主奉献源码。