求助：如何提取12-8-12中的数字，有否源程序

yshf

你的意思是不是使标注的文本与所选定的参照线或文字获倾角相同？

yshf

;试一试函数(qjxt en1 en2)，也许满足你的要求。
;测试函数CC
(defun c:cc()
(while (setq wb (car (entsel "\n请选取文本:")))
(setq en (car (entsel "\n请选择参考点直线或文本:")))
;调用方式(qjxt 要改变倾角的文本图元名 参考点直线或文本图元名)
;要改变倾角的文本图元名可用(setq wb (entlast))取得
(qjxt wb en)
)
)
(defun qjxt(en1 en2 / vob1 vob2 name ang bz)
(vl-load-com)
(setq vob1 (vlax-ename->vla-object en1)
vob2 (vlax-ename->vla-object en2)
name (vla-get-objectname vob2)
)
(cond ((= name "AcDbLine") (setq ang (vla-get-angle vob2)))
((= name "AcDbText") (setq ang (vla-get-rotation vob2)))
)
(vla-put-rotation vob1 ang)
(initget "Y N")
(setq bz (getkword "\n文本的方向符合要求吗？[Yes/No]<Y>:"))
(if (= bz "N") (vla-put-rotation vob1 (+ pi ang)))
)

tc405003

这个是文字与参照线对齐；我想问的是输入文字时，先点取线得角度；再指定标注点，回车后文字便也线平行的标出

yshf

;我明白你的意思了，请试用下面程序。
(defun c:qjxt()
(vl-load-com)
(setq cm (getvar "cmdecho"))(setvar "cmdecho" 0)
(while (setq en (car (entsel "\n请选择参考直线或文本:")))
(setq vo (vlax-ename->vla-object en)
na (vla-get-objectname vo)
)
(if (or (= na "AcDbLine") (= na "AcDbText"))
(progn
(if (setq st (getstring "\n请输入要标注的文本："))
(if (setq pt (getpoint "\n请指定标注点："))
(progn
(setq an (cond ((= na "AcDbLine") (vla-get-angle vo))
((= na "AcDbText") (vla-get-rotation vo))
)
)
(setq os (getvar "osmode")) (setvar "osmode" 0)
(command "_text" pt "" (angtos an 1 6) st)
(setvar "osmode" os)
)
)
)
)
(alert "你所选的参考不是直线或单行文字，请重新选择！")
)
)
(setvar "cmdecho" cm)(princ)
)

tc405003

当标注文字时，选取的线条如果起点和终点的位置不一样的话，字有可能倒的可不可以让字都是正的

yshf

你的意思是选取参考线，再选其一端点作参考点，若该点与参考线的起点相同，则文字是正的；若该点与参考线的止点相同，则文字是倒的？（也就是说：无论该点与参考线的那一端点相同，都必须以该点作起点，另一个端点作止点来确定文字的倾角。）

yshf

;如果是那样的话，请看下面的程序是否中意？
(defun c:qjxt()
(vl-load-com)
(setq cm (getvar "cmdecho"))(setvar "cmdecho" 0)
(while (setq en (car (entsel "\n请选择参考直线或文本:")))
(setq vo (vlax-ename->vla-object en)
na (vla-get-objectname vo)
)
(if (or (= na "AcDbLine") (= na "AcDbText"))
(progn
(cond ((= na "AcDbText") (setq an (vla-get-rotation vo)))
((= na "AcDbLine")
(setq an (vla-get-angle vo)
p0 (getpoint "\n请在参考线上指定一端点作起点:")
)
(if (equal p0 (vlax-curve-getendpoint vo) 1e-3) (setq an (+ an pi)))
)
)

(if (setq st (getstring "\n请输入要标注的文本："))
(if (setq pt (getpoint "\n请指定标注点："))
(progn
(setq os (getvar "osmode")) (setvar "osmode" 0)
(command "_text" pt "" (angtos an 1 6) st)
(setvar "osmode" os)
)
)
)
)
(alert "你所选的参考不是直线或单行文字，请重新选择！")
)
)
(setvar "cmdecho" cm)(princ)
)

YueFeng

yshf发表于2005-6-24 21:06:00将程序改为： (defun tqsz( / ts1) (setq ts1 (cdr (assoc 1 (entget (car (entsel \"\n请选取文字图元:\"))))) ts1 (read (strcat \"(\" ...

此段代码有问题。 (defun tqsz( / ts1)
(setq ts1 (cdr (assoc 1 (entget (car (entsel "\n请选取文字图元:")))))
ts1 (vl-string-translate "-" " " ts1) ;此处有修改。
ts1 (read (strcat "(" (vl-string-translate "G" " " ts1) ")"))
ts1 (apply 'max (vl-remove-if '(lambda (x) (= (numberp x) nil)) ts1))
)

)

tc405003

谢谢各位楼主，太谢谢了

tc405003

;;;=====结构梁重编号=====
(defun C:cbh(/ xsel ysel sel bm tmpsel tmpobj n begin ans va co elist1 elist2 elist3 entmod2 do)
(prompt "\n 非常感谢您的支持！")
(prompt "\n本程序快捷键为 CBH !")
(prompt "\n请选择范围：")
(defun entmod2(code var na / old new na)
(setq old(assoc code na))
(setq new(cons code var))
(setq na(subst new old na))
(entmod na)
)
(setq sel (ssget) add (ssadd))
(prompt "\n>请输入编号前缀 <KL>：")
(setq prefix (getstring))
(if (= prefix "") (setq prefix "KL"))
(setq begin (getint "\n请输入开始编号 <1>："))
(if (not begin) (setq begin 1))
(setq xsel (ssadd) ysel (ssadd) n 0)
(setq bm begin)
(while (< n (sslength sel));分成X向和Y向两组
(setq elist1 (entget(ssname sel n)))
(if (and
(or
(= (cdr (assoc 0 elist1)) "TEXT")
(= (cdr (assoc 0 elist1)) "MTEXT")
);or
(or
(< (cdr (assoc 50 elist1)) (* (/ pi 180) 45))
(>= (cdr (assoc 50 elist1)) (* (/ pi 180) 315))
);or
(wcmatch prefix (substr (cdr (assoc 1 elist1)) 1 (strlen prefix) )) ;是否为梁柱编号
(not (wcmatch "*" (substr (cdr (assoc 1 elist1)) 1 1 )))
);and
(setq ysel (ssadd (ssname sel n) ysel))
);if
(if (and
(or
(= (cdr (assoc 0 elist1)) "TEXT")
(= (cdr (assoc 0 elist1)) "MTEXT")
);or
(and
(>= (cdr (assoc 50 elist1)) (* (/ pi 180) 45))
(< (cdr (assoc 50 elist1)) (* (/ pi 180) 315))
);and
(wcmatch prefix (substr (cdr (assoc 1 elist1)) 1 (strlen prefix) ));是否为梁柱编号
);and
(setq xsel (ssadd (ssname sel n) xsel))
);if
(setq n (+ n 1))
);while
(princ (strcat "\n查找到" (itoa (sslength xsel)) "个X向编号，" (itoa (sslength ysel)) "个Y向编号"))
(princ (strcat "\n一共有" (itoa (+ (sslength xsel) (sslength ysel))) "个编号，正在重新编号，请稍候..."))
(princ "\n...")
(setq tmpsel ysel ysel nil tmpobj nil)
(setq ysel (ssadd))
(while (< 0 (sslength tmpsel));Y向排序（竖向）
(setq tmpobj (ssname tmpsel 0) n 1);取第一个对象
(while (< n (sslength tmpsel));比较大小
(setq elist1 (entget tmpobj));取ELIST1
(setq elist2 (entget(ssname tmpsel n)))
(if
(< (nth 2 (assoc 10 elist2)) (nth 2 (assoc 10 elist1)));如果小于
(setq tmpobj (ssname tmpsel n))
);if
(if
(and (= (nth 2 (assoc 10 elist2)) (nth 2 (assoc 10 elist1))) (< (nth 1 (assoc 10 elist2)) (nth 1 (assoc 10 elist1))) );如果小于
(setq tmpobj (ssname tmpsel n))
);if
(setq n (+ 1 n))
);while
(setq elist3 (entget tmpobj))
(setq co 1)
(setq va (cdr (assoc 1 elist3)))
(setq va (substr va (+ 1 (strlen prefix)) (- (strlen va) (strlen prefix))))
(while (or (> (atoi (substr va 1 1)) 0) (= (substr va 1 1) "0"));是0
(setq va (substr va 2 (strlen va)))
);while
(setq va (strcat prefix (itoa bm) va))
(entmod2 co va elist3)
(setq ysel(ssadd tmpobj ysel))
(setq tmpsel (ssdel tmpobj tmpsel))
(setq bm (+ 1 bm))
);while
(setq tmpsel xsel xsel nil tmpobj nil)
(setq xsel (ssadd))
(while (< 0 (sslength tmpsel));X向排序（竖向）
(setq tmpobj (ssname tmpsel 0) n 1);取第一个对象
(while (< n (sslength tmpsel));比较大小
(setq elist1 (entget tmpobj));取ELIST1
(setq elist2 (entget(ssname tmpsel n)))
(if
(< (nth 1 (assoc 10 elist2)) (nth 1 (assoc 10 elist1)));如果小于
(setq tmpobj (ssname tmpsel n))
);if
(if
(and (= (nth 1 (assoc 10 elist2)) (nth 1 (assoc 10 elist1))) (< (nth 2 (assoc 10 elist2)) (nth 2 (assoc 10 elist1))) );如果小于
(setq tmpobj (ssname tmpsel n))
);if
(setq n (+ 1 n))
);while
(setq elist3 (entget tmpobj))
(setq co 1)
(setq va (cdr (assoc 1 elist3)))
(setq va (substr va (+ 1 (strlen prefix)) (- (strlen va) (strlen prefix))))
(while (or (> (atoi (substr va 1 1)) 0) (= (substr va 1 1) "0"));是0 ;
(setq va (substr va 2 (strlen va)))
);while
(setq va (strcat prefix (itoa bm) va))
(entmod2 co va elist3)
(setq xsel(ssadd tmpobj xsel))
(setq tmpsel (ssdel tmpobj tmpsel))
(setq bm (+ 1 bm))
);while
(if (= bm begin) (princ "\n没有合条件的编号，所以没有重新编号！"))
(if (/= bm begin) (princ (strcat "\n编号由" prefix (itoa begin) "到" prefix (itoa (- bm 1)) )))
(princ)
)
一个结构梁得编号的LISP，但是如果有相同的梁号，而一个是配筋的一个没有，最后号都重新编号了，能否改为如果改编号以前的梁在改编号以后梁号还是一样的