纵横断面面积标注

树櫴希德

1. (defun cx-ss2en
   
2.   (ss / enlst)
   
3.   (cond
   
4.     ((= (type ss) 'PICKSET)
   
5.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
   
6.     )
   
7.     ((= (type ss) 'LIST)
   
8.       (setq enlst (ssadd))
   
9.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
   
10.     )
    
11.     ((='ename(type ss))
    
12.       (ssadd ss)
    
13.     )
    
14.   )
    
15. )
    
16. 
    
17. 
    
18. ;[功能]点表求面积
    
19. (defun getarea (l)
    
20.    (abs(* 0.5
    
21.       (apply
    
22.         '+
    
23.         (mapcar
    
24.           '(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))
    
25.           l
    
26.           (append (cdr l) (list (car l)))
    
27.         )
    
28.       )
    
29.    ) )
    
30. );;;;;;;;;;;;;;;;;;;
    
31. (defun vxs(e / p a b n ob q et d d1 en et)
    
32.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    
33.     (cond((="LWPOLYLINE"et)
    
34.     (repeat(length a)(setq b (nth n a) n (+ n 1))
    
35.       (if (= 10 (car b))(progn
    
36.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
    
37.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
    
38.           (setq p (list q)))))))
    
39.    ((="POLYLINE"et)
    
40.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    
41.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
    
42.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
    
43.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
    
44.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    
45.     (setq p(reverse p))))P)
    
46. ;;;;;;;;;;
    
47. ;;;;;;;;;;;;;;;;;;;;;;;;
    
48. ;;;;;;;;;;;;;;;;;;;
    
49. (defun zxzb (pts / len pt )
    
50.   (setq len (length pts))
    
51. (setq pt (mapcar
    
52.   '(lambda(x)
    
53.     (/ x len)
    
54.   )
    
55.   (apply
    
56.     'mapcar
    
57.     (cons '+ pts)
    
58.   )
    
59. )
    
60. )  pt)
    
61. 
    
62. (defun c:dmmj ( /  hxbl hxbl dmx zbb mj xzzb SSA x);  hxbl hxbl dmx zbb
    
63. 
    
64. (setq hxbl (getint "\n请输入断面横向比例 1 :"))
    
65.   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
    
66. 
    
67. (setq ssa (ssget '( (0 . "LWPOLYLINE")   ) ) ) ;(8 . "0")
    
68. 
    
69.   (foreach x (cx-ss2en ssa)
    
70. ;(setq dmx (car(entsel "\n请选择要标注断面面积的闭合多段线：")))
    
71. (setq zbb (vxs x))
    
72.   (setq xzbb  (mapcar          '(lambda (a ) (list   (* (car a)(/ hxbl 1000.000) )  (* (cadr a)(/ zxbl 1000.000) )     )
    
73.           )
    
74.     zbb)
    
75. 
    
76.    )
    
77. (setq mj (getarea xzbb))
    
78. 
    
79.   (entmake (list '(0 . "TEXT") '(8 . "fgbaj")(cons 1 (rtos mj 2 3)) (cons 10 (zxzb zbb) ) (cons 40 3.0)))
    
80.   
    
81.   )
    
82.        )

(defun cx-ss2en<br />   (ss / enlst)<br />   (cond<br />     ((= (type ss) 'PICKSET)<br />       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />     )<br />     ((= (type ss) 'LIST)<br />       (setq enlst (ssadd))<br />       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />     )<br />     ((='ename(type ss))<br />       (ssadd ss)<br />     )<br />   )<br /> )<br /> <br /> <br /> ;[功能]点表求面积<br /> (defun getarea (l)<br />    (abs(* 0.5<br />       (apply<br />         '+<br />         (mapcar<br />           '(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))<br />           l<br />           (append (cdr l) (list (car l)))<br />         )<br />       )<br />    ) )<br /> );;;;;;;;;;;;;;;;;;;<br /> (defun vxs(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="POLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> ;;;;;;;;;;<br /> ;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;;;;;;;;;;;;;;;;;<br /> (defun zxzb (pts / len pt )<br />   (setq len (length pts))<br /> (setq pt (mapcar<br />   '(lambda(x)<br />     (/ x len)<br />   )<br />   (apply<br />     'mapcar<br />     (cons '+ pts)<br />   )<br /> )<br /> )  pt)<br /> <br /> (defun c:dmmj ( /  hxbl hxbl dmx zbb mj xzzb SSA x);  hxbl hxbl dmx zbb<br /> <br /> (setq hxbl (getint "\n请输入断面横向比例 1 :"))<br />   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))<br /> <br /> (setq ssa (ssget '( (0 . "LWPOLYLINE")   ) ) ) ;(8 . "0")<br /> <br />   (foreach x (cx-ss2en ssa)<br /> ;(setq dmx (car(entsel "\n请选择要标注断面面积的闭合多段线：")))<br /> (setq zbb (vxs x))<br />   (setq xzbb  (mapcar          '(lambda (a ) (list   (* (car a)(/ hxbl 1000.000) )  (* (cadr a)(/ zxbl 1000.000) )     )<br />           )<br />     zbb)<br /> <br />    )<br /> (setq mj (getarea xzbb))<br /> <br />   (entmake (list '(0 . "TEXT") '(8 . "fgbaj")(cons 1 (rtos mj 2 3)) (cons 10 (zxzb zbb) ) (cons 40 3.0)))<br />   <br />   )<br />        )

gzxl

学习学习下

树櫴希德

gzxl 发表于 2019-11-23 08:53
学习学习下

大神大哥你太谦虚； 了

树櫴希德

1. (defun c:zs()
   
2.   (setq ss(ssget'((0 . "insert")(8 . "gcd")))j -1)
   
3.   (setq gcz 0)
   
4.   (repeat(sslength ss)
   
5.     (setq en(ssname ss(setq j(1+ j))))
   
6.     (setq el(entget en))
   
7.     (setq zb10(assoc 10 el))
   
8.     (setq zb(last zb10))
   
9.     (setq gcz(+ gcz zb))
   
10.   )
    
11.   (setq gczs(/ gcz (sslength ss)))
    
12.   (prompt (strcat"\n平均数为：" (rtos gczs 2 3)))
    
13.   (princ)
    
14. )

(defun c:zs()<br />   (setq ss(ssget'((0 . "insert")(8 . "gcd")))j -1)<br />   (setq gcz 0)<br />   (repeat(sslength ss)<br />     (setq en(ssname ss(setq j(1+ j))))<br />     (setq el(entget en))<br />     (setq zb10(assoc 10 el))<br />     (setq zb(last zb10))<br />     (setq gcz(+ gcz zb))<br />   )<br />   (setq gczs(/ gcz (sslength ss)))<br />   (prompt (strcat"\n平均数为：" (rtos gczs 2 3)))<br />   (princ)<br /> )

czb203

大神，发给操作视频下，不太明白怎么使用

树櫴希德

文字连接程序

1. (defun c:tt (/ e el str tl)
   
2.   (if (and (setq e (car (entsel "\nPick First Text: ")))
   
3.            (= (cdr (assoc 0 (setq el (entget e)))) "TEXT")
   
4.       )
   
5.     (progn
   
6.       (setq str (cdr (setq tl (assoc 1 el))))
   
7.       (while (and (setq e1 (car (entsel "\nNext Join: ")))
   
8.                   (= (cdr (assoc 0 (setq el1 (entget e)))) "TEXT")
   
9.              )
   
10.         (setq str (strcat str (cdr (assoc 1 el1))))
    
11.         (entmod        (subst (cons 1 str)
    
12.                        tl
    
13.                        el
    
14.                 )
    
15.         )
    
16.         (entdel e1)
    
17.       )
    
18.     )
    
19.   )
    
20.   (princ)
    
21. )

(defun c:tt (/ e el str tl)<br />   (if (and (setq e (car (entsel "\nPick First Text: ")))<br />            (= (cdr (assoc 0 (setq el (entget e)))) "TEXT")<br />       )<br />     (progn<br />       (setq str (cdr (setq tl (assoc 1 el))))<br />       (while (and (setq e1 (car (entsel "\nNext Join: ")))<br />                   (= (cdr (assoc 0 (setq el1 (entget e)))) "TEXT")<br />              )<br />         (setq str (strcat str (cdr (assoc 1 el1))))<br />         (entmod        (subst (cons 1 str)<br />                        tl<br />                        el<br />                 )<br />         )<br />         (entdel e1)<br />       )<br />     )<br />   )<br />   (princ)<br /> )

f4800

横断面面积标注  感谢分享源码

技术工作室

支持分享源码

技术工作室

支持分享源码

cjf160204

感谢分享源码