社区 › AutoLISP/Visual LISP 编程技术 › 【e派】Z轴归零问题探讨——源码揭秘

xyp1964 发表于 2014-5-7 18:49:39

【e派】Z轴归零问题探讨——源码揭秘

本帖最后由 xyp1964 于 2014-5-8 14:53 编辑

属性块内的属性文本：

普通块内的实体：

;; 先从简单的开始
;; Z轴归零主函数 zzgl
;; 实例: (zzgl (setq s1 (car (entsel "\n选择: "))))
(defun zzgl (s1)
;; 适合于一般实体
(foreach a '(10 11 12 13 14)
    (zzgl-dxf s1 a)
)
)
;; __________________________________________________________________
;; 以下为自定义函数，大部分代码都曾经开源过
;; __________________________________________________________________
(defun xyp-DXF (code s1 / ent lst a)
(if (= (type code) 'LIST)
    (progn
      (setq ent (entget s1)
            lst      '()
      )
      (foreach a code
      (setq lst (cons (list a (cdr (assoc a ent))) lst))
      )
      (reverse lst)
    )
    (if (= code -3)
      (cdr (assoc code (entget s1 '("*"))))
      (cdr (assoc code (entget s1)))
    )
)
)

(defun xyp-Etype (s1 etype)
(wcmatch (xyp-DXF 0 s1) (strcase etype))
)

(defun xyp-SubUpd (s1 code val / ent x y i s1)
(cond ((= (type s1) 'ENAME)
         (setq ent (entget s1))
         (if (and (= (type code) 'LIST) (= (type val) 'LIST))
         (mapcar '(lambda (x y) (xyp-SubUpd s1 x y)) code val)
         (progn
             (if (= (xyp-dxf code s1) nil)
               (entmod (append ent (list (cons code val))))
               (entmod (subst (cons code val) (assoc code ent) ent))
             )
             (entupd s1)
         )
         )
      )
      ((= (type s1) 'PICKSET)
         (setq i -1)
         (while (setq s2 (ssname s1 (setq i (1+ i))))
         (xyp-SubUpd s2 code val)
         )
      )
      ((= (type s1) 'LIST)
         (foreach s2 s1 (xyp-SubUpd s2 code val))
      )
)
s1
)

(defun zzgl-dxf (s1 mode / pt)
(if (and (setq pt (xyp-dxf mode s1))
         (/= (caddr pt) 0)
      )
    (xyp-SubUpd s1 mode (list (car pt) (cadr pt) 0))
)
)
;; __________________________________________________________________
;; 自定义函数
;; __________________________________________________________________

xyp1964 发表于 2014-5-8 19:46:42

;; spline、arc 、块内实体、dxf 210码不正常等等的实体——待后续研究
;; zzgl(Z轴归零)
;; 测试实例
(defun c:zzgl ()
(princ "\n选择归零实体: ")
(if (setq ss (ssget))
    (setq lst (xyp-Ss2List ss)
          lst (mapcar 'xyp-Zzgl lst)
    )
)
(princ)
)

;; Z轴归零主函数 xyp-Zzgl
(defun xyp-Zzgl        (s1 / p10)
;; 属性块实体: 先移位后属性实体归零
(if (and (xyp-Etype s1 "insert")
           (= (xyp-Dxf 66 s1) 1)
      )
    (progn
      (setq p10 (xyp-Dxf 10 s1))
      (xyp-Move s1 p10 (list (car p10) (cadr p10) 0))
      (foreach ob (xyp-AttList s1)
        (xyp-Zzgl (vlax-vla-object->ename ob))
      )
    )
)
;; 一般实体
(foreach a '(10 11 12 13 14)
    (xyp-Zzgl-Dxf s1 a)
)
;; 有38码的实体
(if (/= (setq pt (xyp-Dxf 38 s1)) 0)
    (xyp-SubUpd s1 38 0)
)
;; spline实体、arc 实体、块内实体、dxf 210码不正常的实体
)

tigcat 发表于 2021-2-24 15:10:28

用的天正自带的坐标归零。这个试了后，发现上传的测试图图案填充还有一些块无法坐标归零。

头大无恼 发表于 2017-8-30 09:26:57

ko217 发表于 2015-5-26 21:53
有块不炸开就归零的吗

期待啊:lol

emk 发表于 2014-5-7 18:53:06

院长厉害......垃圾处理利器

kfboy 发表于 2014-5-7 18:56:07

看得见摸不着哦

用户3766035971 发表于 2014-5-7 19:18:56

院长厉害

donghuidong2003 发表于 2014-5-8 12:42:45

期待院长的源码发放……
我的图就是这鬼样的

yiqisese 发表于 2014-5-8 13:06:01

有程序共享不，图多了会不会致命错误

xyp1964 发表于 2014-5-8 14:41:39

;; Z轴归零主函数 zzgl
;; (zzgl (setq s1 (car (entsel "\n选择: "))))
(defun zzgl (ename)
;; 适合于一般实体
(foreach a '(10 11 12 13 14)
    (zzgl-dxf ename a)
)
;; 存在38码的实体
(if (/= (setq pt (xyp-dxf 38 ename)) 0)
    (xyp-SUBUPD ename 38 0)
)
)

rjtiantian 发表于 2014-5-8 14:53:22

火前留名。。。

zichang 发表于 2014-5-8 15:02:02

院长厉害！

txd720127 发表于 2014-5-8 15:24:40

这个确实很实用，顶院长！

查看完整版本: 【e派】Z轴归零问题探讨——源码揭秘