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

gowww

感觉好长啊

yuan4399

(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

yuan4399 发表于 2022-3-22 17:01
(defun c:zzz0 (/ s)
  (setq s (ssget))
  (zzz0 s)

研究精神可嘉