庆祝明经论坛恢复，改造的Z轴归零程序，展示下

尘缘一生 · 发表于 2021-10-22 16:23

本帖最后由尘缘一生于 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，暂且略去不处理。

再见熊猫衣服 · 发表于 2021-10-23 22:55

不知道站长在搞什么名堂，如果没精力搞了，可以转给我，我来继续维护。

yuan4399 · 发表于 2022-3-22 17:01

(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)
)

尘缘一生 · 发表于 2021-10-24 16:40

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
)

这都函数罢了，

tigcat · 发表于 2021-10-22 22:21

感谢尘缘分享.

stonedesign · 发表于 2021-10-23 08:53

我都等了好久的明经了，这次奔溃的有点久哈哈。

k1nger · 发表于 2021-10-23 10:55

同贺，关了半个月，终于重见天日

ynhh · 发表于 2021-10-23 17:19

论坛恢复是

值得高兴的事

谢谢大师的分享

尘缘一生 · 发表于 2021-10-23 23:20

再见熊猫衣服发表于 2021-10-23 22:55
不知道站长在搞什么名堂，如果没精力搞了，可以转给我，我来继续维护。

不是站长的事，是服务器问题，也不一定是黑客攻击，可能服务器在维护吧。

lxl217114 · 发表于 2021-10-24 11:34

选择对象: ; 错误: no function definition: _UNDO1

tiduck · 发表于 2021-10-24 11:59

CAD2020显示
错误: no function definition: _UNDO1

账号		自动登录	找回密码
密码			注册

庆祝明经论坛恢复，改造的Z轴归零程序，展示下

点评