[编程申请]：将线段的高度归零程序

zhangjiayin

急需高度归零程序

aeo

论坛有的，找找.


最简单的
(command "move"(ssget)"" "0,0""@0,0,1e200"
                   move "P""" "0,0""@0,0,-1e200")

但有时会出错.

陌生人

请问aeo，什么时候出错？

leochen

;;;改变图素Z轴坐标
(defun C:gd (/ a b c d n i)
  (graphscr)
  (setq        a (getint (strcat "\n输入高度:"))
        b (ssget "x")
        n (sslength b)
        i 0
  )
  (setvar "elevation" a)
  (while (< i n)                        ;while
    (setq c (entget (ssname b i))
          i (+ i 1)
    )
    (if        (setq d (assoc 38 c))                ;if~~~
      (setq d (cons 38 a)
            c (subst d (assoc 38 c) c)
      )
      (progn
        (if (cadddr (assoc 10 c))        ;if!!!
          (setq        d (assoc 10 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 10 c) c)
          )
        )                                ;endif!!!
        (if (cadddr (assoc 11 c))        ;if@@@
          (setq        d (assoc 11 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 11 c) c)
          )
        )                                ;endif@@@
        (if (cadddr (assoc 12 c))        ;if###
          (setq        d (assoc 12 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 12 c) c)
          )
        )                                ;endif###
        (if (cadddr (assoc 13 c))        ;if$$$
          (setq        d (assoc 13 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 13 c) c)
          )
        )                                ;endif$$$
        (if (cadddr (assoc 14 c))        ;if%%%
          (setq        d (assoc 14 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 14 c) c)
          )
        )                                ;endif%%%
        (if (cadddr (assoc 15 c))        ;if^^^
          (setq        d (assoc 15 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 15 c) c)
          )
        )                                ;endif^^^
        (if (cadddr (assoc 16 c))        ;if&&&
          (setq        d (assoc 16 c)
                d (subst a (cadddr d) d)
                c (subst d (assoc 16 c) c)
          )
        )                                ;endif&&&
      )
    )                                        ;endif~~~
    (entmod c)
  )                                        ;endwhile
  (princ)
)

YueFeng

直接调用CHANGE命令不行吗？

jsrlb

;;;　将所选对象Z轴坐标改为零
(defun C:BGZ0 (/ s1 a1)
  (command "undo" "be")
  (setq s1 (ssget));;;选择对象
  (if (/= s1 nil)
    (progn
      (command "_.move" s1 "" '(0 0 1e99) ""
               "_.move" "_p" "" '(0 0 -1e99) ""
      )
      (setq a1 (sslength s1))
      (setq a1 (strcat "共" (rtos a1) "个对象的Z坐标值改为零"))
      (princ "\n")
      (princ a1)
    )
    (progn
      (princ"\n无选择对象")
    )
  )
  (command "undo" "e")
  (princ)
)

lemonx

晓东工具箱里面有现成的，很好用

yw_gxr

晓东工具箱里面的有时候好象无效.

陌生人

谁来贴一个块内实体也压平的？

userzhluserzhl

支持楼上的陌生人 ,我也需要这样的功能,要不陌生人你自己写出来吧,我跟你买.

doubao

auotocad 的express tools里flatten objects 就是压平所选实体的工具。