一个简化版本的图元坐标值圆整程序，源码奉献
本帖最后由 vectra 于 2014-10-19 18:45 编辑看到highflybir这个非常有创意的程序
[【高飞鸟】] 【飞鸟集】数据取整（更新至2012.6）http://bbs.mjtd.com/thread-86961-1-1.html
心想，符合CAD编程规则的图元，用作坐标的组码值是有一定要求的，所以应该可以用很简单统一的代码实现，于是有了下面这个版本的数据取整程序。理论上应该支持各种已知或未知的图元类型。
highflybir的代码没有深入地看，可能各自对基点和容差的理解、实现各不相同。
在我的版本里，圆整值的含义是：坐标各分量只能是圆整值的整数倍，和“标注舍入”的实现类似。当然，这个简化版本在可靠性和错误处理上要弱一点，而且我这里没有天正或其它有自定义实体的软件，因此也没有办法对自定义的实体进行测试，欢迎大家测试反馈。
(vl-load-com)
(setq *tolerance* 1)
(defun ceiling (n tor)
(* (fix (+ 0.5 (/ n tor))) tor)
)
(defun c:fix (/ fixpointgroup fixdxf base dxf ent i offset len ss tor)
(defun fixpointgroup (p)
(mapcar '(lambda (e) (ceiling e *tolerance*)) (mapcar '+ offset p))
)
(defun fixdxf (dxf)
;; 见 DXF 参考 > DXF 格式 > 组码值类型。10-39 双精度三维点值
;; 测试中发现部分 3x 组码并非点，安全起见仅处理 10-14 常用表示点的组码值
(setq dxf (mapcar '(lambda (e)
(if (and (>= (car e) 10) (<= (car e) 14))
(cons (car e) (fixpointgroup (cdr e)))
e
)
)
dxf
)
)
(entmod dxf)
)
(setq ss (ssget))
(if ss
(progn
(setq base (getpoint (strcat "\n指定修正基点:"))) ;_ 基点意在圆整坐标时最小化图元相对位置改变
(if (null base)
(vl-exit-with-value 1)
)
(initget 6)
(setq tor (getreal (strcat "\n请输入坐标圆整值: <" (rtos *tolerance* 2 3) ">")))
(if tor
(setq *tolerance* tor)
)
(setq offset (mapcar '- (mapcar '(lambda (e) (ceiling e *tolerance*)) base) base))
(setq len (sslength ss)
i 0
)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(repeat len
(setq ent (ssname ss i)
dxf (entget ent)
)
(cond
((= "POLYLINE" (cdr (assoc 0 dxf)))
(setq ent (entnext ent))
(while (/= (cdr (assoc 0 (setq dxf (entget ent)))) "SEQEND")
(fixdxf dxf)
(setq ent (entnext ent))
)
)
;; TODO: 增加其它复合对象处理
;; 其它类型实体均采用该方法处理
(t (fixdxf dxf))
)
(setq i (1+ i))
)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
)
(princ)
)
支持源码。 支持楼主奉献源码。
页:
[1]