[LISP程序]：有没有这样的LISP程序？

cnnets · 发表于 2002-5-5 11:03:15

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

请问，有没有这样的LISP程序：在天正中改选中的所有标高同时加或减一数值，如：标高为3.100，8.200，11.300等，均加上0.200，即变为3.300，8.400，11.500等，而其字的属性不变。

cy956 · 发表于 2002-5-5 11:11:50

有。

没有也可以自己写。

cnnets · 发表于 2002-5-6 07:06:01

你能帮个忙写出来吧。

ll_j · 发表于 2002-5-6 07:24:37

我的ce.lsp（Lisp程序库论坛中计算器程序贴）可以对你有点帮助，使用时注意提示，输出方式应为改写。

cy956 · 发表于 2002-5-6 12:07:10

cnnets ：
每个人的标高定义方式可能不同，
有的人用pline线＋text，
有的人用块＋属性字。

你可以先选择一个基点，
然后根据y高，刷新所有选中的标高符的值。

其实几乎所有的带建筑功能的程序（网友自制），
都有这样类似功能的程序。

InterCAD · 发表于 2002-5-6 16:15:40

;;;==========================================================;
;;;加减高程数值 ;
;;;==========================================================;
(defun c:PlusValue (/ el k ss zl
oldList oldText oldValue newList newValue
)
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(if (not ss)
(exit)
)
(setq zl (getreal "\n增减数值<0>: "))
(if (= zl nil)
(setq zl 0)
)
(setq k 0)
(repeat (sslength ss)
(setq el (entget (ssname ss k))
oldList (assoc 1 el)
oldText (cdr oldList)
oldValue (read oldText)
)
(if (or (= (type oldValue) 'INT) (= (type oldValue) 'REAL))
(progn
(setq newValue (rtos (+ oldValue zl) 2 3)
newList (cons (car oldList) newValue)
el (subst newList oldList el)
)
(entmod el)
)
)
(setq k (1+ k))
)
(princ)
)

;;;==========================================================; 
;;;加减高程数值                                                          ; 
;;;==========================================================; 
(defun c:PlusValue (/             el              k               ss        zl 
                    oldList  oldText  oldValue newList        newValue 
                   ) 
  (setq ss (ssget '((0 . "TEXT,MTEXT")))) 
  (if (not ss) 
    (exit) 
  ) 
  (setq zl (getreal "\n增减数值<0>: ")) 
  (if (= zl nil) 
    (setq zl 0) 
  ) 
  (setq k 0) 
  (repeat (sslength ss) 
    (setq el           (entget (ssname ss k)) 
          oldList  (assoc 1 el) 
          oldText  (cdr oldList) 
          oldValue (read oldText) 
    ) 
    (if        (or (= (type oldValue) 'INT) (= (type oldValue) 'REAL)) 
      (progn 
        (setq newValue (rtos (+ oldValue zl) 2 3) 
              newList  (cons (car oldList) newValue) 
              el       (subst newList oldList el) 
        ) 
        (entmod el) 
      ) 
    ) 
    (setq k (1+ k)) 
  ) 
  (princ) 
)

XDSoft · 发表于 2002-5-6 16:53:49

最初由 cnnets 发布
[B]请问，有没有这样的LISP程序：在天正中改选中的所有标高同时加或减一数值，如：标高为3.100，8.200，11.300等，均加上0.200，即变为3.300，8.400，11.500等，而其字的属性不变。 [/B]

以前我写过，可以智能排序，找到最下的标高，看看下面的介绍。

;;; 给天正建筑3.x加入两个命令，使用天正核心，仅适用天正3.x版本
;;; 本程序可以窗口多选要改变层高的标注值，程序找出最下面的层高值，
;;;然后提示后的最下面层的层高
;;; 然后，计算出差值，连续修改选中的最下层及其上部各层的标注值
;;; c:e_chdim 连续改变立面层高标注值
;;; c:s_chdim 连续改变剖面层高标注值
;;; 两个命令基本相同，仅仅是提示不同
;;; 为考虑以后兼容，请朋友们把本程序保存为elev_chdim.lsp

下载看下面的帖子

http://www.xdcad.net/forum/showthread.php?postid=6851#post6851

cnnets · 发表于 2002-5-7 07:07:20

我好开心，有这么多热心的朋友回答，谢谢你们啦。

xiguo · 发表于 2002-5-12 06:55:48

以前自己编一程序做到统一加减标高，不过画图时自己先将标高值做成属性，与标高线做成块，所以在这时才能用到本程序。本程序可以解决如F+2.500标高加300变为F+2.800。也可解决2.500标高变为2.800。

[FONT=courier new]
(defun c:zx (/ var1 blk entcn i bg blki
flag bktext bkent atext atextd bgtext bgvalue
bgf bgL valueb len flag1 valxao atext1
bknet
)
(alert (strcat
"-----------------------------------------------\n"
" 本程序可用于带属性的标高块，当标高值以一相\n"
"同高差改变时，统一改变标高---------------------\n"
"-----------------------------------------------\n"
" 01,1,30\n"
"-----------------------------------------------")
)
(setq var1 (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq blk (ssget '((0 . "INSERT"))))
(setq entcn (sslength blk))
(setq i 0)
(initget 24)
(setq bg (getreal "输入变化标高值:"))
(while (< i entcn)
(princ i)
(setq blki (ssname blk i))
(setq flag 1)
(setq flag1 0) ;(while flag
(setq bktext (entnext blki))
(setq bkent (entget bktext))
(setq atext (assoc 0 bkent))
(setq atextd (cdr atext))
(if (= atextd "SEQEND")
(seq flag 0)
) ;end if
(if (= atextd "ATTRIB")
(progn
(setq flag 0)
(setq bgtext (assoc 1 bkent))
(setq bgtext (cdr bgtext))
(setq bgvalue (vl-string->list bgtext))
(if
(or (and
(< 47 (car bgvalue))
(> 58 (car bgvalue))
)
(= 45 (car bgvalue))
)
(setq bgf nil
bgL bgvalue
flag1 1
)
) ;end if
(if (or
(= 43 (cadr bgvalue))
(= 45 (cadr bgvalue))
) ;end or
(setq bgf (car bgvalue)
bgL (cdr bgvalue)
)
) ;end if
(if (or
(= 43 (caddr bgvalue))
(= 45 (caddr bgvalue))
) ;end or
(setq bgf (list (car bgvalue) (cadr bgvalue))
bgL (cddr bgvalue)
)
) ;end if
(setq valueb (vl-list->string bgL))
(setq valueb (atof valueb))
(setq valueb (+ bg valueb))
(if (= valueb (fix valueb))
(setq len 0)
) ;end if
(setq valueb (rtos valueb 2 3))
;|(setq valzhe (fix valueb))
(setq valxao
(cond
((minusp valzhe) (- valzhe valueb))
((>= valzhe 0) (- valueb valzhe))
) ;end cond
) ;end setq
(setq valzhe (itoa valzhe))
(setq valxao (rtos valxao 2 3))
(if (< (setq len (strlen valxao)) 5)
(setq valxao
(cond
((= 1 len) "0.000")
((= 3 len) (strcat valxao "00"))
((= 4 len) (strcat valxao "0"))
) ;end cond
) ;end setq
) ;end if
(setq valxao (vl-string-left-trim "0" valxao))
(setq valueb (strcat valzhe valxao))|;
(setq bgL (vl-string->list valueb))
(setq valxao
(cond
((= 46 (cadr bgL)) (cddr bgL)) ;.
((= 46 (caddr bgL)) (cdddr bgL))
((= 46 (cadddr bgL)) (cddddr bgL))
(T "0")
) ;end cond
) ;end setq
(if (< (setq len (vl-list-length valxao)) 3)
(setq bgL
(append bgL
(cond
((= 0 len) '(46 48 48 48))
((= 1 len) '(48 48))
((= 2 len) '(48))
(T nil)
)
) ;end cond
) ;end setq
) ;end if
(if (and (/= 1 flag1)
(/= 45 (car bgL))
) ;-
(setq bgL (cons 43 bgL)) ;+
)
(if (/= 1 flag1)
(setq bgvalue (cons bgf bgL))
)
(if (= 1 flag1)
(setq bgvalue bgL)
)
(setq atext1 (vl-list->string bgvalue))
(setq bkent (subst (cons 1 atext1) (assoc 1 bkent) bkent))
(entmod bkent)
;(setq flag 0)
(entupd blki)
) ;end progn
) ;end if
;) ;end while flag
(setq i (1+ i))
) ;end while entcn
) ;end defun
(defun *error* (msg)
(alert "你怎么不好好用呢？\n")
;(princ msg)
(princ)
)
(if (or (/= msg "Function cancalled")
(= msg "quit / exit about")
)
(princ)
(princ (stract "\n Error:" msg))
)
(princ "高度转换；输入zx：")
(princ)[/FONT]

[FONT=courier new] 
(defun c:zx (/             var1    blk     entcn   i             bg             blki 
             flag    bktext  bkent   atext   atextd  bgtext  bgvalue 
             bgf     bgL     valueb  len     flag1   valxao  atext1 
             bknet 
            ) 
  (alert (strcat 
           "-----------------------------------------------\n" 
           "     本程序可用于带属性的标高块，当标高值以一相\n" 
           "同高差改变时，统一改变标高---------------------\n" 
           "-----------------------------------------------\n" 
           "                              01,1,30\n" 
           "-----------------------------------------------") 
  ) 
  (setq var1 (getvar "cmdecho")) 
  (setvar "cmdecho" 0) 
  (setq blk (ssget '((0 . "INSERT")))) 
  (setq entcn (sslength blk)) 
  (setq i 0) 
  (initget 24) 
  (setq bg (getreal "输入变化标高值:")) 
  (while (
    (princ i) 
    (setq blki (ssname blk i)) 
    (setq flag 1) 
    (setq flag1 0)                        ;(while flag 
    (setq bktext (entnext blki)) 
    (setq bkent (entget bktext)) 
    (setq atext (assoc 0 bkent)) 
    (setq atextd (cdr atext)) 
    (if        (= atextd "SEQEND") 
      (seq flag 0) 
    )                                        ;end if 
    (if        (= atextd "ATTRIB") 
      (progn 
        (setq flag 0) 
        (setq bgtext (assoc 1 bkent)) 
        (setq bgtext (cdr bgtext)) 
        (setq bgvalue (vl-string->list bgtext)) 
        (if 
          (or (and 
                (< 47 (car bgvalue)) 
                (> 58 (car bgvalue)) 
              ) 
 
              (= 45 (car bgvalue)) 
 
          ) 
           (setq bgf   nil 
                 bgL   bgvalue 
                 flag1 1 
           ) 
        )                                ;end if 
        (if (or 
              (= 43 (cadr bgvalue)) 
              (= 45 (cadr bgvalue)) 
            )                                ;end or 
          (setq        bgf (car bgvalue) 
                bgL (cdr bgvalue) 
          ) 
        )                                ;end if 
        (if (or 
              (= 43 (caddr bgvalue)) 
              (= 45 (caddr bgvalue)) 
            )                                ;end or 
          (setq        bgf (list (car bgvalue) (cadr bgvalue)) 
                bgL (cddr bgvalue) 
          ) 
        )                                ;end if 
        (setq valueb (vl-list->string bgL)) 
        (setq valueb (atof valueb)) 
        (setq valueb (+ bg valueb)) 
 
        (if (= valueb (fix valueb)) 
          (setq len 0) 
        )                                ;end if 
        (setq valueb (rtos valueb 2 3)) 
        ;|(setq valzhe (fix valueb)) 
          (setq        valxao 
                 (cond 
                   ((minusp valzhe) (- valzhe valueb)) 
                   ((>= valzhe 0) (- valueb valzhe)) 
                 )                        ;end cond 
          )                                ;end setq 
          (setq valzhe (itoa valzhe)) 
          (setq valxao (rtos valxao 2 3)) 
          (if (< (setq len (strlen valxao)) 5) 
            (setq valxao 
                   (cond 
                     ((= 1 len) "0.000") 
 
                     ((= 3 len) (strcat valxao "00")) 
                     ((= 4 len) (strcat valxao "0")) 
                   )                        ;end cond 
            )                                ;end setq 
          )                                ;end if 
          (setq valxao (vl-string-left-trim "0" valxao)) 
          (setq valueb (strcat valzhe valxao))|; 
 
        (setq bgL (vl-string->list valueb)) 
        (setq valxao 
               (cond 
                 ((= 46 (cadr bgL)) (cddr bgL)) ;. 
                 ((= 46 (caddr bgL)) (cdddr bgL)) 
                 ((= 46 (cadddr bgL)) (cddddr bgL)) 
                 (T "0") 
               )                        ;end cond 
        )                                ;end setq 
 
        (if (< (setq len (vl-list-length valxao)) 3) 
          (setq        bgL 
                 (append bgL 
                         (cond 
                           ((= 0 len) '(46 48 48 48)) 
                           ((= 1 len) '(48 48)) 
                           ((= 2 len) '(48)) 
                           (T nil) 
                         ) 
                 )                        ;end cond 
          )                                ;end setq 
        )                                ;end if 
 
        (if (and (/= 1 flag1) 
                 (/= 45 (car bgL)) 
            )                                ;- 
          (setq bgL (cons 43 bgL))        ;+ 
        ) 
        (if (/= 1 flag1) 
          (setq bgvalue (cons bgf bgL)) 
        ) 
        (if (= 1 flag1) 
          (setq bgvalue bgL) 
        ) 
 
        (setq atext1 (vl-list->string bgvalue)) 
        (setq bkent (subst (cons 1 atext1) (assoc 1 bkent) bkent)) 
        (entmod bkent) 
                                        ;(setq flag 0) 
        (entupd blki) 
      )                                        ;end progn 
    )                                        ;end if 
                                        ;)                                        ;end while flag 
    (setq i (1+ i)) 
  )                                        ;end while entcn 
 
)                                        ;end defun 
 
(defun *error* (msg) 
  (alert  "你怎么不好好用呢？\n") 
  ;(princ msg) 
  (princ) 
 
) 
(if (or        (/= msg "Function cancalled") 
        (= msg "quit / exit about") 
    ) 
  (princ) 
  (princ (stract "\n Error:" msg)) 
) 
(princ "高度转换； 输入zx：") 
(princ)[/FONT]

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：有没有这样的LISP程序？

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

加减高程数值

Re: [LISP程序]：有没有这样的LISP程序？

统一加减标高