社区 › AutoLISP/Visual LISP 编程技术 › 现有复制标高能增加标高数值，如何实现拉伸或者移动标高同样可以改变标高数值（已....

注册 发表于 2013-4-19 10:23:05

现有复制标高能增加标高数值，如何实现拉伸或者移动标高同样可以改变标高数值（已....

本帖最后由 注册 于 2013-4-29 22:57 编辑

;;复制标高，标高数字自动修改
(defun c:jbg ()
;(PXT_ER)
(defun DXF (n da) (cdr (assoc n da)))
(setq      xtblm '("osmode" "clayer" "cecolor" "orthomode" "plinewid")
      xtblz (mapcar 'getvar xtblm)
)
(setvar "osmode" 1) ;_捕捉端点
(princ "\n请选择要复制\"图层为_B标高\"的标高(退出)：")
;;;(setq      ss (ssget ":L"
;;;                  (list (cons 8 "B标高"))
;;;         )
;;;)
(setq ss (ssget))
(if ss
    (progn
      (command "undo" "be")
      (if (null bl-cb)
      (setq bl-cb 1.0)
      )
      (prompt (strcat "\n当前缩放比例:【" (rtos bl-cb 2 1) "】"))
      (initget "Bili")
      (setq p1 (getpoint "\nBili改变比例/ 基点(退出)："))
      (while (= p1 "Bili")
      (setq
          bl-cb2
         (getreal (strcat "\n请输入比例:<" (rtos bl-cb 2 1) ">")
         )
      )
      (if bl-cb2
          (setq bl-cb bl-cb2)
          (setq bl-cb bl-cb)
      )
      (prompt (strcat "\n当前缩放比例:【" (rtos bl-cb 2 1) "】"))
      (initget "Bili")
      (setq p1 (getpoint "\nBili改变比例/ 基点(退出)："))
      )
      ;;--------------------------------------------
      (setvar "osmode" 673) ;_捕捉端点、交叉点、最近点 垂足
      (while (setq p2 (getpoint p1 "\n拷贝至 (退出): "))
      ;;-------------------------------
      ;; 返回复制后，新生成的物体ss_new
      (setq en_Last (entlast)
            ss_new(ssadd)
      )
      (command "copy" ss "" p1 p2)
      (setq en_next (entnext en_Last))
      (while en_next
          (ssadd en_next ss_new)
          (setq en_next (entnext en_next))
      )
      ;;------------------------------
      (setq i 0)
      (repeat      (sslength ss_new)
          (setq      en   (ssname ss_new i)
                da   (entget en)
                enty (DXF 0 da)
          )
          (cond
            ;;处理：普通标高text 天正标高
            ((member enty (list "TEXT" "TCH_ELEVATION"))
             (setq txt (DXF 1 da))
             (if (or (= txt "%%p0.000")
                     (= txt "0") ;_Tch标高为 (1 . "0")
                     (and (/= (atof txt) 0)
                        (wcmatch txt "*.*")
                     )
               )
               (progn
               ;;--计算高差----
               (setq d   (- (cadr p2) (cadr p1))
                     d   (* d 0.001 bl-cb)
                     num (+ (atof txt) d)
               )
               (setq txt-n (rtos num 2 3))
               (if (= txt-n "0.000")
                   (setq txt-n "%%p0.000")
               )
               ;;-------------
               (setq da (subst (cons 1 txt-n) (assoc 1 da) da))
               (entmod da)
               )
             )
            )
            ;;处理：属性标高
            ((member enty (list "INSERT"))
             (setq da(entget (entnext en))
                   txt (DXF 1 da)
             )
             ;;--计算高差----
             (setq d   (- (cadr p2) (cadr p1))
                   d   (* d 0.001 bl-cb)
                   num (+ (atof txt) d)
             )
             (setq txt-n (rtos num 2 3))
             (if (= txt-n "0.000")
               (setq txt-n "%%p0.000")
             )
             ;;-------------
             ;;============================
             ;; 替换属性文字
             (setq da (entget (entnext en)))
             (setq da (subst (cons 1 txt-n) (assoc 1 da) da))
             (entmod da)
             (entupd en)
             (entupd (entnext en))
             ;;============================
            )
          ) ;_ cond
          (setq i (1+ i))
      ) ;_end repeat
      ) ;_end while
      (command "undo" "e")
    )
) ;_ if ss
(mapcar 'setvar xtblm xtblz)
(princ)
)
以上是网络上寻找到的复制标高同时能增加标高数值的源码（感谢原作者），现有复制标高能增加标高数值，如何实现拉伸或者移动标高同样可以改变标高数值？请赐教

注册 发表于 2013-4-19 12:08:11

自己顶一下

vlisp2012 发表于 2013-4-19 19:46:54

盼望高手出现啊！同求！

注册 发表于 2013-4-19 20:24:22

vlisp2012 发表于 2013-4-19 19:46 static/image/common/back.gif
盼望高手出现啊！同求！

自己改了一下，没有用啊

注册 发表于 2013-4-21 13:06:09

继续顶，呵呵

xsso 发表于 2013-4-21 14:11:08

如果你用的CAD版本较高的话，虽然我不什么高手，但可以参考一下我之前发过的字段功能
http://bbs.mjtd.com/thread-100352-1-1.html
它会按实际情况自动更新

注册 发表于 2013-4-21 22:36:01

xsso 发表于 2013-4-21 14:11 static/image/common/back.gif
如果你用的CAD版本较高的话，虽然我不什么高手，但可以参考一下我之前发过的字段功能
http://bbs.mjtd.com ...

多谢指点，去看看先

pxt2001 发表于 2013-4-27 10:19:24

这个程序好像是我以前发的。
如果移动就改变标高的话，更简单了。
修改以下的ss_new选择集，改为你移动的选择集。

;; 返回复制后，新生成的物体ss_new
      (setq en_Last (entlast)
            ss_new(ssadd)
      )
      (command "copy" ss "" p1 p2)
      (setq en_next (entnext en_Last))
      (while en_next
          (ssadd en_next ss_new)
          (setq en_next (entnext en_next))
      )
      ;;------------------------------
      (setq i 0)
      (repeat      (sslength ss_new)

自贡黄明儒 发表于 2013-4-27 12:52:23

估计你需要的是反应器。这个有点深，玩不好都会崩溃的。

注册 发表于 2013-4-27 15:43:31

自贡黄明儒 发表于 2013-4-27 12:52 static/image/common/back.gif
估计你需要的是反应器。这个有点深，玩不好都会崩溃的。

谢谢，一切安好？

查看完整版本: 现有复制标高能增加标高数值，如何实现拉伸或者移动标高同样可以改变标高数值（已....