求帮忙改下求和lsp，求和结果覆盖选择的文本
这个lsp挺好用，定义精度，求和，写文本到CAD，但是我想要的是最后一步提示选择文本，然后把求和结果覆盖过去，哪位帮忙改下呢。(DEFUN C:KK()
(setq jd (getint "input 精度<0>:"))
(if (= jd nil) (setq jd 0))
(princ "\nselect object:")
(setq s (ssget))
(setq n (sslength s))
(setq k 0 )(setq mm 0.0)
(while (< k n)
(setq name (ssname s k))
(setq a (entget name))
(setq t1 (assoc '0 a))
(setq t1 (cdr t1))
(if (= t1 "TEXT") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(setq tx (atof tx))
(setq mm (+ tx mm))
))
(if (= t1 "DIMENSION") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(if (and (/= tx "")(/= tx "<>"))(setq tx (atof tx)))
(if (or (= tx "")(= tx "<>"))(progn
(setq tx (assoc '42 a))
(setq tx (cdr tx))
))
(if (= k 0) (setq MM TX) (setq mm (+ tx mm)))
))
(setq k (+ k 1))
)
(setq mm (rtos mm 2 jd))
(setq po (getpoint "\n指定计算结果的写入点:"))
(command "text" po """" mm)
)
到我的网络U盘（看签名）去下载一个Ce.lsp，功能比你想要的多。 本帖最后由 尘缘一生 于 2018-7-5 18:30 编辑
【三领外挂】采用的，提供出来
;;-------求和并写出-----------------------------------------------------------
(defun c:qiuhe(/ e e1 p n l l1 d pt0 pt2 pt3 ang hi)
(command)
(SSET)
(setvar "LUPREC" 2);;;;精度到小数点后2位
(setq pt0 0)
(setq e(ssget))
(setq p (sslength e))
(setq n 0)
(setq p (- p 1))
(while (<= n p)
(setq e1(entget(ssname e n)))
(if (="TEXT" (cdr(assoc 0 e1)))
(progn
(setq pt2(atof(cdr(assoc 1 e1))))
(setq pt0(+ pt0 pt2))
)
)
(setq n(+ n 1))
)
(alert(setq pt0 (rtos pt0))) ;;;;;把和数字变为字符串,并显示出来
(setq l(strlen pt0))
(while (="0" (substr pt0 l))
(setq pt0 (substr pt0 1 (- l 1)))
(setq l(strlen pt0))
)
(if (="." (substr pt0 l))
(setq pt0 (substr pt0 1 (- l 1)))
(setq l(strlen pt0))
)
(CHZI)
(SSET1)
)
;;----------------------------------------------------------------------------
(defun SSET( )
(setq oldos (getvar "OSMODE"))
(setq oldorh (getvar "ORTHOMODE"))
(setq oldsn (getvar "SNAPMODE"))
(setq oldlup (getvar "LUPREC"))
(setvar "OSMODE" 0) ;;;捕捉关闭
(setvar "ORTHOMODE" 0) ;;;正交关闭
(setvar "SNAPMODE" 0);;;;实体捕捉关闭
(setvar "CMDECHO" 0)
(setvar "TEXTEVAL" 1)
)
;;---------------------------------------------------------------------------
(defun SSET1( )
(setvar "ORTHOMODE" oldorh);;;恢复正交
(setvar "OSMODE" oldos);;;恢复正交
(setvar "SNAPMODE" oldsn) ;;;;恢复实体捕捉
(setvar "LUPREC" oldlup);;;;恢复数值小数位数
(setvar "CMDECHO" 1)
)
;;------根据给出的字符串pt0改-写字符----------------------------------------------------
(defun CHZI ( )
(setq oldlup (getvar "LUPREC"))
(setvar "LUPREC" 0);;;;精度到各位,以便后续取得标准颜色号
(princ "\n 选择修改数字，空选(右键）即写出: ")
(setq e1(ssget))
(if (/= e1 nil)
(progn
(setq p (sslength e1))
(setq n 0)
(setq p (- p 1))
(while (<= n p)
(setq e(entget(ssname e1 n)))
(if (OR (="TEXT" (cdr(assoc 0 e)))(="MTEXT" (cdr(assoc 0 e))))
(progn
(setq ang(angtos (cdr(assoc 50 e)) 0 2))
(setq hi(cdr(assoc 40 e)))
(setq sty(cdr(assoc 7 e)))
(setq pt1(cdr(assoc 10 e)))
(entdel(ssname e1 n))
(command "TEXT" "S" sty pt1 hi ang pt0)
(vl-cmdf "_.JustifyText" (entlast) "" "ML")
(command "CHANGE" (entlast) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS") 8))) "")
);;;;progn
);;;; end if
(setq n (+ n 1))
);;;;while
);;;progn
)
(if (= e1 nil)
(progn
(setq pt3 (nth 1 (grread 5)));取得文字写入点
(command "TEXT" pt3 (* (getvar "DIMSCALE") 3.0) 0 pt0)
(vl-cmdf "_.JustifyText" (entlast) "" "ML")
(command "MOVE" (entlast) "" pt3 pause"")
(command "CHANGE" (entlast) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS") 8))) "")
) ; progn
)
(setvar "LUPREC" oldlup);;;;恢复数值小数位数
)
;;-----------------------------------------------------------------------------------
ll_j 发表于 2018-7-5 17:33
到我的网络U盘（看签名）去下载一个Ce.lsp，功能比你想要的多。
谢谢前辈，您的lsp里最后一步没有我要的功能，就是计算结果覆盖指定文本，其他的运算，常青藤软件的求和都能实现的。 尘缘一生 发表于 2018-7-5 18:27
【三领外挂】采用的，提供出来
多谢！最后一步有数据覆盖指定文本了，但是能否删除一部分啊，不想要弹窗提示，覆盖的数据会变颜色，这个功能可以去掉吗，然后还缺个精度指定参数。。。。。我只想要个简单的求和加覆盖指定文件 (DEFUN C:KK()
(setvar "cmdecho" 0)
(setq jd (getint "input 精度<0>:"))
(if (= jd nil) (setq jd 0))
(princ "\nselect object:")
(setq s (ssget))
(setq n (sslength s))
(setq k 0 )(setq mm 0.0)
(while (< k n)
(setq name (ssname s k))
(setq a (entget name))
(setq t1 (assoc '0 a))
(setq t1 (cdr t1))
(if (= t1 "TEXT") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(setq tx (atof tx))
(setq mm (+ tx mm))
))
(if (= t1 "DIMENSION") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(if (and (/= tx "")(/= tx "<>"))(setq tx (atof tx)))
(if (or (= tx "")(= tx "<>"))(progn
(setq tx (assoc '42 a))
(setq tx (cdr tx))
))
(if (= k 0) (setq MM TX) (setq mm (+ tx mm)))
))
(setq k (+ k 1))
)
(setq mm (rtos mm 2 jd))
(initget "1 2")
(setq fs(getkword "\n(1)新建文本 (2)覆盖文本<1>:"))
(cond
((or(= fs "1")(= fs nil))
(setq po (getpoint "\n指定计算结果的写入点:"))
(command "text" po """" mm)
)
((= fs "2")
(while(/= (cdr(assoc 0 (setq en (entget(car (entsel "\n请选择要覆盖的文本: ")))))) "TEXT"))
(entmod (subst (cons 1 mm) (assoc 1 en) en))
)
)
(setvar "cmdecho" 1)
) 本帖最后由 lifuq1979 于 2018-7-6 18:26 编辑
希望可以帮到你，最好把(setq s (ssget))改成
(setq s (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))选取纯数字文本 (DEFUN C:KK()
(setvar "cmdecho" 0)
(setq jd (getint "input 精度<0>:"))
(if (= jd nil) (setq jd 0))
(princ "\nselect object:")
;(setq s (ssget))
(setq s (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))
(setq n (sslength s))
(setq k 0 )(setq mm 0.0)
(while (< k n)
(setq name (ssname s k))
(setq a (entget name))
(setq t1 (assoc '0 a))
(setq t1 (cdr t1))
(if (= t1 "TEXT") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(setq tx (atof tx))
(setq mm (+ tx mm))
))
(if (= t1 "DIMENSION") (PROGN
(setq tx (assoc '1 a))
(setq tx (cdr tx))
(if (and (/= tx "")(/= tx "<>"))(setq tx (atof tx)))
(if (or (= tx "")(= tx "<>"))(progn
(setq tx (assoc '42 a))
(setq tx (cdr tx))
))
(if (= k 0) (setq MM TX) (setq mm (+ tx mm)))
))
(setq k (+ k 1))
)
(setq mm (rtos mm 2 jd))
(initget "1 2")
(setq fs(getkword "\n(1)新建文本 (2)覆盖文本<1>:"))
(cond
((or(= fs "1")(= fs nil))
(setq po (getpoint "\n指定计算结果的写入点:"))
(command "text" po """" mm)
)
((= fs "2")
(while(/= (cdr(assoc 0 (setq en (entget(car (entsel "\n请选择要覆盖的文本: ")))))) "TEXT"))
(entmod (subst (cons 1 mm) (assoc 1 en) en))
)
)
(setvar "cmdecho" 1)
) 希望可以帮到你 简化了一下
(DEFUN C:KK()
(setvar "cmdecho" 0)
(setq jd (getint "input 精度<0>:"))
(if (= jd nil) (setq jd 0))
(setq s (ssget '((0 . "TEXT") (1 . "~*[~`--9]*"))))
(setq k -1 mm 0.0)
(repeat (sslength s)
(setq a (entget (ssname s (setq k(1+ k)))))
(setq tx (cdr (assoc '1 a)))
(setq tx (atof tx))
(setq mm (+ tx mm))
)
(setq mm (rtos mm 2 jd))
(initget "1 2")
(setq fs(getkword "\n(1)新建文本 (2)覆盖文本<1>:"))
(cond
((or(= fs "1")(= fs nil))
(setq po (getpoint "\n指定计算结果的写入点:"))
(command "text" po """" mm)
)
((= fs "2")
(while(/= (cdr(assoc 0 (setq en (entget(car (entsel "\n请选择要覆盖的文本: ")))))) "TEXT"))
(entmod (subst (cons 1 mm) (assoc 1 en) en))
)
)
(setvar "cmdecho" 1)
)
页:
[1]
2