求按标准线拉伸或缩短线的lsp程序0003

品茗新秀

做一个过程演示双击下图   可更加清楚



其实就是把柱梁向右移动100mmm

品茗新秀

品茗新秀 发表于 2012-9-9 12:06
做一个过程演示

双击上图可更加清楚

【KAIXIN】

LISP不是万能的，有些东西不能一个程序解决，得分开来

crazylsp

选一个标准长度再选其它，都变成标准长度并写出字"d8@200"，是这个意思吗? 有弯钩否?

品茗新秀

crazylsp 发表于 2012-9-24 10:07
选一个标准长度再选其它，都变成标准长度并写出字"d8@200"，是这个意思吗? 有弯钩否?

不问有无弯钩，对没有标注的钢筋补上标注d8@200

sscylh

楼主,不知道有vba您同意吗?我自己对lisp几乎一窍不通,就会些基础很常用,像vl函数都不会.............
vba还可以,应该用lisp能做的,vba应该也都能做吧

品茗新秀

sscylh 发表于 2012-9-24 18:32
楼主,不知道有vba您同意吗?我自己对lisp几乎一窍不通,就会些基础很常用,像vl函数都不会.............
vb ...

行，同意，只好从vba中找感觉，

yjr111

图层就是钢筋标注图层，只不过我把文字颜色改为红色显眼一点罢了，，，

yjr111

附上源码：

2. (defun getmp(e / midp)
   
3.   (setq midp(vlax-curve-getPointAtParam e(/(-(vlax-curve-getEndParam e)
   
4.                  (vlax-curve-getStartParam e)) 2))
   
5.         )
   
6. )
   
7. (defun maketxt(e / sp ep mp pam1 newe newmp txtp)
   
8.   (if (= 3.0 (vlax-curve-getEndParam e))
   
9.     (progn
   
10.       (setq sp(vlax-curve-getPointAtParam e 0)
    
11.             ep(vlax-curve-getPointAtParam e 3)
    
12.             mp(getmp e)
    
13.             pam1(vlax-curve-getPointAtParam e 1)
    
14.             pam2(vlax-curve-getPointAtParam e 2)
    
15.             ang(angle sp ep)
    
16.             )
    
17.       (entmake (list '(0 . "LINE") (cons 10 sp) (cons 11 ep)))
    
18.       (setq newe(entlast)
    
19.             newmp(getmp newe)
    
20.             DIS (DISTANCE sp pam1)
    
21.             )      
    
22.       (entdel newe)
    
23.       (setq ep1(polar ep (angle ep pam2)(+ DIS 100)))
    
24.       (setq areadss(ssget "c" sp ep1 '((0 . "TEXT")(1 . "*[@]*"))))
    
25.       (if  areadss (setq ang1(cdr(assoc 50 (entget(ssname areadss 0))))))
    
26.       (if (or (not areadss)(/= ang ang1))                                       
    
27.         (PROGN
    
28.           (setq txtp(polar newmp (angle sp pam1)(+ DIS 50)))      
    
29.           (entmake (list '(0 . "TEXT") (cons 1 "%%1328@200")(cons 8 "板底钢筋标注")
    
30.                       (cons 10 '(0 0 0)) (cons 11 txtp)(cons 40 160)
    
31.                       (cons 50 ang)(cons 62 1)(cons 72 1)(cons 73 1)
    
32.                       )
    
33.           )
    
34.         )
    
35.       )
    
36.     )
    
37.   )
    
38. )
    
39. (defun c:xgj(/ ss n)
    
40.   (command "undo" "be")
    
41.   (setq ss(ssget '((0 . "LWPOLYLINE")(8 . "*钢筋"))))
    
42.   (if ss
    
43.   (repeat (setq n(sslength ss))
    
44.     (maketxt (ssname ss (setq n(1- n))))
    
45.     )
    
46.   )
    
47.   (command "undo" "e")
    
48.   (princ)
    
49.   )
    
50.        

(defun getmp(e / midp)<br />   (setq midp(vlax-curve-getPointAtParam e(/(-(vlax-curve-getEndParam e) <br />                  (vlax-curve-getStartParam e)) 2))<br />         )<br /> )<br /> (defun maketxt(e / sp ep mp pam1 newe newmp txtp)<br />   (if (= 3.0 (vlax-curve-getEndParam e))<br />     (progn<br />       (setq sp(vlax-curve-getPointAtParam e 0)<br />             ep(vlax-curve-getPointAtParam e 3)<br />             mp(getmp e)<br />             pam1(vlax-curve-getPointAtParam e 1)<br />             pam2(vlax-curve-getPointAtParam e 2)<br />             ang(angle sp ep)<br />             )<br />       (entmake (list '(0 . "LINE") (cons 10 sp) (cons 11 ep)))<br />       (setq newe(entlast)<br />             newmp(getmp newe)<br />             DIS (DISTANCE sp pam1)<br />             )      <br />       (entdel newe)<br />       (setq ep1(polar ep (angle ep pam2)(+ DIS 100)))<br />       (setq areadss(ssget "c" sp ep1 '((0 . "TEXT")(1 . "*[@]*"))))<br />       (if  areadss (setq ang1(cdr(assoc 50 (entget(ssname areadss 0))))))<br />       (if (or (not areadss)(/= ang ang1))                                       <br />         (PROGN<br />           (setq txtp(polar newmp (angle sp pam1)(+ DIS 50)))      <br />           (entmake (list '(0 . "TEXT") (cons 1 "%%1328@200")(cons 8 "板底钢筋标注")<br />                       (cons 10 '(0 0 0)) (cons 11 txtp)(cons 40 160)<br />                       (cons 50 ang)(cons 62 1)(cons 72 1)(cons 73 1)<br />                       )<br />           )<br />         )<br />       )<br />     )<br />   )<br /> )<br /> (defun c:xgj(/ ss n)<br />   (command "undo" "be")<br />   (setq ss(ssget '((0 . "LWPOLYLINE")(8 . "*钢筋"))))<br />   (if ss<br />   (repeat (setq n(sslength ss))<br />     (maketxt (ssname ss (setq n(1- n))))<br />     )<br />   )<br />   (command "undo" "e")<br />   (princ)<br />   )<br />        

goldwheat

这个很实用的，下载了，多谢分享源码。