求LISP程序：块中块Z坐标归零
本帖最后由 fengyu6913 于 2023-11-13 11:35 编辑求LISP程序：块中块Z坐标归零
本帖最后由 panliang9 于 2023-11-15 08:51 编辑
明经的巨大贡献
http://bbs.mjtd.com/forum.php?mo ... hlight=%D5%B9%C6%BD
第三个文件也一样能处理，还是用这个程序
本帖最后由 yaojing38 于 2023-11-13 17:31 编辑
;;;**************Z坐标归零 程序开始**************
(defun c:zzz ()
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(princ "\n★功能:将所有对象的Z坐标归零.")
(command "_.UCS" "")
(command "_.move"
"_all"
""
'(0
0
1e305
)
""
"_.move"
"_p"
""
'(0
0
-1e305
)
""
)
(princ "\n提示：已将图形中所有对象的Z坐标归零.")
(princ)
)
;;;**************Z坐标归零 程序结束**************
;;;**************Z坐标归零 程序开始**************
(defun c:zzz0 (/ s)
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(princ "\n★功能:将所选对象的Z坐标归零.")
(command "_.UCS" "")
(if (setq s (ssget))
(command "_.move" s "" '(0 0 1e305) "" "_.move" "_p" "" '(0 0 -1e305) "")
)
(princ "\n提示：已将所选对象的Z坐标归零.")
(princ)
)
;;;**************Z坐标归零 程序结束**************
;以下均为论坛大佬代码，，建议你先搜搜在发问题 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))
)
)
)
) panliang9 发表于 2023-11-15 08:28
明经的巨大贡献
http://bbs.mjtd.com/forum.php?mo ... hlight=%D5%B9%C6%BD
感谢大佬分享，这个能解决绝大部分块中块归零问题 弥勒 发表于 2023-11-18 15:45
(defun c:z0()
(setq cmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
感谢大佬分享，经测试这个只能解决块外面的图元不归零 本帖最后由 KO你 于 2023-12-2 00:02 编辑
快捷键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))
快捷键z0Z轴归零
(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 eblock
(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)
)
)
(setqlen (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)
配合这三个程序，你上面几个文件我都下载试过，可以处理
页:
[1]