求LISP程序：块中块Z坐标归零

fengyu6913

求LISP程序：块中块Z坐标归零

panliang9

明经的巨大贡献
http://bbs.mjtd.com/forum.php?mo ... hlight=%D5%B9%C6%BD

第三个文件也一样能处理，还是用这个程序

yaojing38

2. ;;;**************Z坐标归零 程序开始**************
   
3. (defun c:zzz ()
   
4.   (setvar "osmode" 15359)
   
5.   (setvar "cmdecho" 0)
   
6.   (princ "\n★功能:将所有对象的Z坐标归零.")
   
7.   (command "_.UCS" "")
   
8.   (command "_.move"
   
9.      "_all"
   
10.      ""
    
11.      '(0
    
12.        0
    
13.        1e305
    
14.       )
    
15.      ""
    
16.      "_.move"
    
17.      "_p"
    
18.      ""
    
19.      '(0
    
20.        0
    
21.        -1e305
    
22.       )
    
23.      ""
    
24.   )
    
25.   (princ "\n提示：已将图形中所有对象的Z坐标归零.")
    
26.   (princ)
    
27. )
    
28. ;;;**************Z坐标归零 程序结束**************
    
29. ;;;**************Z坐标归零 程序开始**************
    
30. (defun c:zzz0 (/ s)
    
31.   (setvar "osmode" 15359)
    
32.   (setvar "cmdecho" 0)
    
33.   (princ "\n★功能:将所选对象的Z坐标归零.")
    
34.   (command "_.UCS" "")
    
35.   (if (setq s (ssget))
    
36.     (command "_.move" s "" '(0 0 1e305) "" "_.move" "_p" "" '(0 0 -1e305) "")
    
37.   )
    
38.   (princ "\n提示：已将所选对象的Z坐标归零.")
    
39.   (princ)
    
40. )
    
41. ;;;**************Z坐标归零 程序结束**************

;;;**************Z坐标归零 程序开始**************<br /> (defun c:zzz ()<br />   (setvar "osmode" 15359)<br />   (setvar "cmdecho" 0)<br />   (princ "\n★功能:将所有对象的Z坐标归零.")<br />   (command "_.UCS" "")<br />   (command "_.move"<br />      "_all"<br />      ""<br />      '(0<br />        0<br />        1e305<br />       )<br />      ""<br />      "_.move"<br />      "_p"<br />      ""<br />      '(0<br />        0<br />        -1e305<br />       )<br />      ""<br />   )<br />   (princ "\n提示：已将图形中所有对象的Z坐标归零.")<br />   (princ)<br /> )<br /> ;;;**************Z坐标归零 程序结束**************<br /> ;;;**************Z坐标归零 程序开始**************<br /> (defun c:zzz0 (/ s)<br />   (setvar "osmode" 15359)<br />   (setvar "cmdecho" 0)<br />   (princ "\n★功能:将所选对象的Z坐标归零.")<br />   (command "_.UCS" "")<br />   (if (setq s (ssget))<br />     (command "_.move" s "" '(0 0 1e305) "" "_.move" "_p" "" '(0 0 -1e305) "")<br />   )<br />   (princ "\n提示：已将所选对象的Z坐标归零.")<br />   (princ)<br /> )<br /> ;;;**************Z坐标归零 程序结束**************

;以下均为论坛大佬代码，，建议你先搜搜在发问题

fengyu6913

yaojing38 发表于 2023-11-13 17:21
;以下均为论坛大佬代码，，建议你先搜搜在发问题

经验证此方法不能使块中块不归零图元归零

弥勒

(defun c:z0()
        (setq cmdecho (getvar "cmdecho"))
        (setvar "cmdecho" 0)
(alert "

                 注意!!!!!!!!!!!

   本程序用于将图中所有线、物的 Z 值变为 零 !

========================================================


                                                             ")
               (setq ssgcd (ssget "X" ))
          (if ssgcd
                (progn
                    (setq n (sslength ssgcd) n0 0)
                    (repeat n
                        (setq ssi (ssname ssgcd n0))
                        (command "change"  ssi "" "p" "e" "0" "")
                        (setq n0 (+ n0 1))
                    )
                )
        )
)

fengyu6913

panliang9 发表于 2023-11-15 08:28
明经的巨大贡献
http://bbs.mjtd.com/forum.php?mo ... hlight=%D5%B9%C6%BD

感谢大佬分享，这个能解决绝大部分块中块归零问题

fengyu6913

弥勒 发表于 2023-11-18 15:45
(defun c:z0()
        (setq cmdecho (getvar "cmdecho"))
        (setvar "cmdecho" 0)

感谢大佬分享，经测试这个只能解决块外面的图元不归零

KO你

快捷键  z00  选择对象Z轴归零
(defun c:z00 (/ ss)
(setvar "cmdecho" 0)
(if (setq ss (ssget))
(command ".MOVE" ss "" "0,0,0" "0,0,1000e99" ".MOVE" "P" "" "0,0,1000e99" "0,0,0"))
(princ "\n已将选择的图元标高值归零.")
(princ))

快捷键  z0  Z轴归零
(vl-load-com)

(defun getboundingbox (ename / lb ur)
  (vla-getboundingbox
    (vlax-ename->vla-object ename)
    'lb
    'ur
  )
  (mapcar 'vlax-safearray->list (list lb ur))
)
;;


(defun move-region-to-wcs-plan (ename / obj z)
  (setq obj (vlax-ename->vla-object ename))
  (if (and
  (= "AcDbRegion" (vla-get-objectname obj))
  (/= 0.0 (setq z (caddr (car (getboundingbox ename)))))
      )
    (vla-move obj
        (vlax-3d-point (list 0 0 z))
        (vlax-3d-point (list 0 0 0))
    )
  )
)
;; (move-region-to-wcs-plan(car(entsel)))


;; <a href="http://bbs.mjtd.com/thread-93123-1-1.html" target="_blank">http://bbs.mjtd.com/thread-93123-1-1.html</a>
(defun correct210 (ent / obj za)
  (setq obj (vlax-ename->vla-object 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))))
;;;    (progn
;;;      (setq za (vlax-safearray->list
;;;     (vlax-variant-value (vla-get-normal obj))
;;;         )
;;;      )
;;;      (vla-transformby
;;;  obj
;;;  (vlax-tmatrix
;;;    (list
;;;      (list 1 0 (car za) 0)
;;;      (list 0 1 (cadr za) 0)
;;;      (list 0 0 (caddr za) 0)
;;;      (list 0 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)
  )
)

(defun zero-ent  (e / dxf new)
  ;;(correct210 e)

  (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 zero-block (/)
  (vlax-for block (vla-get-blocks
        (vla-get-activedocument (vlax-get-acad-object))
      )
    (vlax-for e  block
      (zero-ent (vlax-vla-object->ename e))
    )
  )
)


(defun c:z0 (/ c10 c38 dxf ent i len ss)
  (princ "选择需要将Z坐标或标高属性清零的对象 <回车选择所有图元>: ")
  
  (setq ss (ssget))
  (if (null ss)
    (setq ss (ssget "_X"))
  )
  (if (null ss)
    (progn (princ "\n选择集空")
     (quit)
    )
  )

  (setq  len (sslength ss)
  i   0
  c10 0
  c38 0
  )

  (vla-startundomark
    (vla-get-activedocument (vlax-get-acad-object))
  )

  ;; 块定义内实体归零
  (zero-block)

  (repeat len

    (zero-ent (setq ent (ssname ss i)))

;;;      ((wcmatch (cdr (assoc 0 dxf)) "INSERT,POLYLINE")
;;;       (setq ent (entnext ent))
;;;      
;;;       (while (and ent
;;;       (setq et (cdr (assoc 0 (setq dxf (entget ent)))))
;;;       (= et "ATTDEF")
;;;       (/= et "SEQEND")
;;;        )
;;;   (zero-ent ent)
;;;   (setq ent (entnext ent))
;;;       )
;;;      )
    (setq i (1+ i))
  )


  (vla-endundomark
    (vla-get-activedocument (vlax-get-acad-object))
  )

  (command "_.regen")

  (princ (strcat "选择的 "
     (itoa len)
     " 个对象中,\n"
     (itoa c10)
     " 个非零Z坐标, "
     (itoa c38)
     " 个标高属性被强制清零."
   )
  )
(princ))





快捷键  qz  三维转二维
(defun c:qz () (c:flatten))
(defun c:flatten ( / ss ans )
(acet-error-init (list nil 1))

(princ "\n选择要转换为二维的对象...")
(if (not acet:flatn-hide)
     (setq acet:flatn-hide "No")
);if

(if (and (setq ss (ssget "_:l" '((-4 . "<NOT") (0 . "VIEWPORT") (-4 . "NOT>"))));setq
          (setq ss (car (acet-ss-filter (list ss nil T))))
     );and
     (progn
      (initget "Yes No")
      (setq ans (getkword
                 (acet-str-format "\n删除隐藏线? <%1>: "
                                  acet:flatn-hide
                 )
                );getkword
      );setq
      (if (not ans)
          (setq ans acet:flatn-hide)
          (setq acet:flatn-hide ans)
      );if
      (if (equal ans "No")
          (acet-flatn ss nil)
          (acet-flatn ss T)
      );if
     );progn then
);if
(acet-error-restore)
);defun c:flatten


(acet-autoload2        '("FLATTENSUP.LSP"        (acet-flatn ss hide)))
(princ)

KO你

配合这三个程序，你上面几个文件我都下载试过，可以处理