庆祝明经论坛恢复，改造的Z轴归零程序，展示下
本帖最后由 尘缘一生 于 2021-10-22 23:48 编辑[*];;Z坐标归零
[*](defun c:zzz0 (/ s)
[*](setq s (ssget))
[*](zzz0 s)
[*])
[*];;Z坐标归零-------【开始】-----------------
[*]
[*];;----实体归零（一级）------------
[*](defun zero-ent (e / dxf new)
[*](defun move-region-to-wcs-plan (ename / obj z)
[*] (setq obj (en2obj ename))
[*] (if (and
[*] (= "AcDbRegion" (vla-get-objectname obj))
[*] (/= 0.0 (setq z (caddr (car (get-box ename)))))
[*] )
[*] (vla-move obj (vlax-3d-point (list 0 0 z)) (vlax-3d-point (list 0 0 0)))
[*] )
[*])
[*];;210组码处理---------------------
[*](defun correct210 (ent / obj za)
[*] (setq obj (en2obj ent))
[*] (if (and (vlax-property-available-p obj 'normal t)
[*] (not (equal '(0 0 1) (setq za (vlax-safearray->list (vlax-variant-value (vla-get-normal obj))))))
[*] )
[*] (vl-catch-all-apply 'vla-put-normal (list obj (vlax-3d-point '(0 0 1))))
[*] )
[*])
[*];;------------------------------------
[*](defun zero-group (e)
[*] (cond
[*] ;; 处理 10-14 段，含 Z 坐标且非零组码，设置Z = 0.0
[*] ((and (>= (car e) 10)
[*] (<= (car e) 14)
[*] (> (length e) 3)
[*] (/= 0.0 (nth 3 e))
[*] )
[*] (setq c10 (1+ c10))
[*] (cons (car e) (list (cadr e) (caddr e) 0.0))
[*] )
[*] ;; 处理 38 段（标高属性）
[*] ((and (= (car e) 38) (/= 0.0 (cdr e)))
[*] (setq c38 (1+ c38))
[*] '(38 . 0.0)
[*] )
[*] ;; 其余组码原样返回
[*] (t e)
[*] )
[*])
[*](correct210 e) ;;210组码强制转换
[*](setq dxf (entget e))
[*](if (= (cdr (assoc 0 dxf)) "REGION")
[*] (move-region-to-wcs-plan e)
[*] (progn
[*] (setq new (mapcar 'zero-group dxf))
[*] (if (not (equal dxf new))
[*] (entmod new)
[*] )
[*] )
[*])
[*]new
[*])
[*];;选择集归零---------(一级)------------------
[*](defun zzz0 (ss / c10 c38 dxf ent i len cmd)
[*](setq len (sslength ss) i 0 c10 0 c38 0 cmd (getvar "cmdecho"))
[*](_Undo1)
[*](repeat len
[*] (setq ent (ssname ss i))
[*] (if (or (and (= (dxf1 ent 0) "ELLIPSE") (/= (dxf1 ent 41) 0)) ;椭圆弧BUG，采用二次归零处理
[*] (and (= (dxf1 ent 0) "ARC") (/= (dxf1 ent 370) nil)) ;370组码存在
[*] )
[*] (progn
[*] (princ "\n 二次归零...")
[*] (setvar "cmdecho" 0)
[*] (terpri)
[*] (command ".ucs" "w")
[*] (command ".move" ent "" '(0 0 1e99) "" ".move" "p" "" '(0 0 -1e99) "")
[*] )
[*] (if (/= (dxf1 ent 0) "INSERT")
[*] (zero-ent ent)
[*] )
[*] )
[*] (setq i (1+ i))
[*])
[*](_Undo2)
[*](command "_.regen")
[*](princ (strcat "\n 选择的 " (itoa len) " 个对象中,\n" (itoa c10) " 个非零Z坐标, \n" (itoa c38) " 个标高被强制清零-->图元Z坐标值已全部归零"))
[*](setvar "cmdecho" cmd)
[*])
[*];;Z坐标归零-------【结束】-----------------
对于块内实体归零，还是没有好代码存在，会有BUG，暂且略去不处理。
不知道站长在搞什么名堂，如果没精力搞了，可以转给我，我来继续维护。 (defun c:zzz0 (/ s)
(setq s (ssget))
(zzz0 s)
)
;;Z坐标归零-------【开始】-----------------
;;----实体归零（一级）------------
(defun zero-ent (e / dxf new)
(defun move-region-to-wcs-plan (ename / obj z)
(setq obj (en2obj ename))
(if (and
(= "AcDbRegion" (vla-get-objectname obj))
(/= 0.0 (setq z (caddr (car (get-box ename)))))
)
(vla-move obj (vlax-3d-point (list 0 0 z)) (vlax-3d-point (list 0 0 0)))
)
)
;;210组码处理---------------------
(defun correct210 (ent / obj za)
(setq obj (en2obj ent))
(if (and (vlax-property-available-p obj 'normal t)
(not (equal '(0 0 1) (setq za (vlax-safearray->list (vlax-variant-value (vla-get-normal obj))))))
)
(vl-catch-all-apply 'vla-put-normal (list obj (vlax-3d-point '(0 0 1))))
)
)
;;------------------------------------
(defun zero-group (e)
(cond
;; 处理 10-14 段，含 Z 坐标且非零组码，设置Z = 0.0
((and (>= (car e) 10)
(<= (car e) 14)
(> (length e) 3)
(/= 0.0 (nth 3 e))
)
(setq c10 (1+ c10))
(cons (car e) (list (cadr e) (caddr e) 0.0))
)
;; 处理 38 段（标高属性）
((and (= (car e) 38) (/= 0.0 (cdr e)))
(setq c38 (1+ c38))
'(38 . 0.0)
)
;; 其余组码原样返回
(t e)
)
)
(correct210 e) ;;210组码强制转换
(setq dxf (entget e))
(if (= (cdr (assoc 0 dxf)) "REGION")
(move-region-to-wcs-plan e)
(progn
(setq new (mapcar 'zero-group dxf))
(if (not (equal dxf new))
(entmod new)
)
)
)
new
)
;;选择集归零---------(一级)------------------
(defun zzz0 (ss / c10 c38 dxf ent i len cmd)
(setq len (sslength ss) i 0 c10 0 c38 0 cmd (getvar "cmdecho"))
(_Undo1)
(repeat len
(setq ent (ssname ss i))
(if (or (and (= (dxf1 ent 0) "ELLIPSE") (/= (dxf1 ent 41) 0)) ;椭圆弧BUG，采用二次归零处理
(and (= (dxf1 ent 0) "ARC") (/= (dxf1 ent 370) nil)) ;370组码存在
)
(progn
(princ "\n 二次归零...")
(setvar "cmdecho" 0)
(terpri)
(command ".ucs" "w")
(command ".move" ent "" '(0 0 1e99) "" ".move" "p" "" '(0 0 -1e99) "")
)
(if (/= (dxf1 ent 0) "INSERT")
(zero-ent ent)
)
)
(setq i (1+ i))
)
(_Undo2)
(command "_.regen")
(princ (strcat "\n 选择的 " (itoa len) " 个对象中,\n" (itoa c10) " 个非零Z坐标, \n" (itoa c38) " 个标高被强制清零-->图元Z坐标值已全部归零"))
(setvar "cmdecho" cmd)
) lxl217114 发表于 2021-10-24 11:34
选择对象:; 错误: no function definition: _UNDO1
[*](if (null vlax-dump-object) (vl-load-com));;将 Visual LISP 扩展功能加载到 AutoLISP----0000级加载
[*];;常量定义
[*](setq *Acad* (vlax-get-acad-object)
[*]*AcDocument* (vla-get-activedocument *Acad*); 获取当前图档指针
[*]*Model-Space* (vla-get-modelspace *AcDocument*)
[*]*Paper-Space* (vla-get-PaperSpace *AcDocument*)
[*]*BLKS* (vla-get-Blocks *AcDocument*)
[*]*LAYS* (vla-get-Layers *AcDocument*)
[*]*ACLYS*(vla-get-activeLayer *AcDocument*)
[*]*LTS*(vla-get-Linetypes *AcDocument*)
[*]pi2 (* pi 0.5)
[*]pi4 (* pi 0.25)
[*]3pi4 (* 0.75 pi)
[*]2pi (+ pi pi)
[*]3pi2 (+ 3pi4 3pi4);; (* 1.5 pi)
[*]5pi4 (+ pi pi4);;(* 1.25 pi)
[*]7pi4 (+ 3pi2 pi4) ;;(* 1.75 pi)
[*])
[*]
[*];;-----------------------------------------------
[*](defun _Undo1 () (vla-StartUndoMark *AcDocument*))
[*];;-----------------------------------------------
[*](defun _Undo2 () (vla-EndUndoMark *AcDocument*))
[*]
[*];;例:(setq h (dxf1 ent 40)) ; ent 为实体名或实体entget，取得图元参数值内容----------（一级）------------------
[*](defun dxf1 (ent i / tmp)
[*](if (= (type ent) 'ENAME)
[*] (setq ent (entget ent '("*")))
[*])
[*](setq tmp (cdr (assoc i ent)))
[*](if (null tmp)
[*] (cond
[*] ((= i 66) 0)
[*] ((= i 62) 256)
[*] ((= i 370) (setq tmp -1))
[*] ((= i 6) "ByLayer")
[*] )
[*] tmp
[*])
[*])
[*]
[*];;返回 obj的 vla对象名-------(一级)------------------
[*](defun en2obj (object)
[*](cond
[*] ((= (type object) 'vla-object)
[*] object
[*] )
[*] ((= (type object) 'ename)
[*] (vl-catch-all-apply '(lambda () (setq object (vlax-ename->vla-object object))));;避免天正实体出错退出
[*] )
[*])
[*]object
[*])
这都函数罢了，
感谢尘缘分享. 我都等了好久的明经了，这次奔溃的有点久哈哈。 同贺，关了半个月，终于重见天日 论坛恢复是
值得高兴的事
谢谢大师的分享 再见熊猫衣服 发表于 2021-10-23 22:55
不知道站长在搞什么名堂，如果没精力搞了，可以转给我，我来继续维护。
不是站长的事，是服务器问题，也不一定是黑客攻击，可能服务器在维护吧。 选择对象:; 错误: no function definition: _UNDO1 CAD2020显示
错误: no function definition: _UNDO1