根据图面三角网计算喷锚边坡表面积并统计

树櫴希德

根据图面三角网计算喷锚边坡表面积并统计，解决工程中基坑边坡喷锚面积统计问题，前提是测量数据准确、三角网符合实际地形。

2. (defun vxs (e / i v lst)
   
3.   (setq i 0)
   
4.   (while
   
5.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
   
6.      (setq lst (cons v lst))
   
7.   )
   
8.   (reverse lst))
   
9. ;;;;;;;;;;;;;;;
   
10. 
    
11. 
    
12. 
    
13. (defun c:tt11 ( / lst ent pts pt demj zmj ) ;标记三角网表面积
    
14. 
    
15.   (setq lst (ssget '( (0 . "polyline") (8 . "sjw")) ) )
    
16. (setq i 0)
    
17. (setq zmj 0.000)
    
18.   
    
19. (while  (< i (sslength lst))
    
20. 
    
21. (setq ent (ssname lst i))
    
22. 
    
23. (setq pts (vxs ent))
    
24.   (setq len (length pts))
    
25. (setq pt (mapcar
    
26.   '(lambda(x)
    
27.     (/ x len)
    
28.   )
    
29.   (apply
    
30.     'mapcar
    
31.     (cons '+ pts)
    
32.   )
    
33. )
    
34. )
    
35. 
    
36. (setq    AcadObject   (vlax-get-acad-object)
    
37. 
    
38.           AcadDocument (vla-get-ActiveDocument Acadobject)
    
39. 
    
40.           mSpace    (vla-get-ModelSpace Acaddocument)) ;初始化系统
    
41. 
    
42. 
    
43.   
    
44. 
    
45.   (setq demj (vlax-curve-getArea  (vlax-ename->vla-object ent)))
    
46.   
    
47.   (entmake (list (cons 0  "TEXT") (cons 1 (rtos demj 2 3)) (cons 10 pt)
    
48.                (cons 40 0.5)
    
49.                (cons 8 "三角网表面积")
    
50.                ))
    
51. 
    
52. 
    
53.   
    
54.   
    
55.   
    
56. (setq zmj(+ zmj demj))
    
57. 
    
58. (setq i (+ i 1))
    
59.   
    
60.   
    
61.   )
    
62. (entmake (list (cons 0  "TEXT") (cons 1 (rtos zmj 2 3)) (cons 10 (getpoint "\请输入总表面积插入点"))
    
63.                (cons 40 3)
    
64.                (cons 8 "三角网表面积")
    
65.                ))
    
66. (print zmj)
    
67.   (princ)
    
68. 
    
69. )

(defun vxs (e / i v lst)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (reverse lst))<br /> ;;;;;;;;;;;;;;;<br /> <br /> <br /> <br /> (defun c:tt11 ( / lst ent pts pt demj zmj ) ;标记三角网表面积<br /> <br />   (setq lst (ssget '( (0 . "polyline") (8 . "sjw")) ) )<br /> (setq i 0)<br /> (setq zmj 0.000)<br />   <br /> (while  (< i (sslength lst))<br /> <br /> (setq ent (ssname lst i))<br /> <br /> (setq pts (vxs ent))<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 /> )<br /> <br /> (setq    AcadObject   (vlax-get-acad-object)<br /> <br />           AcadDocument (vla-get-ActiveDocument Acadobject)<br /> <br />           mSpace    (vla-get-ModelSpace Acaddocument)) ;初始化系统<br /> <br /> <br />   <br /> <br />   (setq demj (vlax-curve-getArea  (vlax-ename->vla-object ent)))<br />   <br />   (entmake (list (cons 0  "TEXT") (cons 1 (rtos demj 2 3)) (cons 10 pt)<br />                (cons 40 0.5)<br />                (cons 8 "三角网表面积")<br />                ))<br /> <br /> <br />   <br />   <br />   <br /> (setq zmj(+ zmj demj))<br /> <br /> (setq i (+ i 1))<br />   <br />   <br />   )<br /> (entmake (list (cons 0  "TEXT") (cons 1 (rtos zmj 2 3)) (cons 10 (getpoint "\请输入总表面积插入点"))<br />                (cons 40 3)<br />                (cons 8 "三角网表面积")<br />                ))<br /> (print zmj)<br />   (princ)<br /> <br /> )

树櫴希德

选择节点少于3个的三维多段线

1. (defun vxs (e / i v lst)
   
2.   (setq i 0)
   
3.   (while
   
4.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
   
5.      (setq lst (cons v lst))
   
6.   )
   
7.   (reverse lst))
   
8. ;;;;;;;;;;;;;;;
   
9. 
   
10. (defun c:xz11 (/ kk lst i ent pts len)
    
11. 
    
12. (setq lst (ssget '( (0 . "polyline") (8 . "0,sjw")) ) )
    
13. (setq i 0)
    
14. 
    
15. (setq kk (ssadd))
    
16. (while  (< i (sslength lst))
    
17. 
    
18. (setq ent (ssname lst i))
    
19. 
    
20. (setq pts (vxs ent))
    
21.   (setq len (length pts))
    
22. 
    
23. (if (< len 3) (ssadd ent kk)) ;;;选择节点少于3个的三维多段线
    
24. 
    
25. 
    
26. (setq i (+ i 1))
    
27.   
    
28.   
    
29.   )
    
30. 
    
31. (sssetfirst nil kk)
    
32.   
    
33.   )

(defun vxs (e / i v lst)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (reverse lst))<br /> ;;;;;;;;;;;;;;;<br /> <br /> (defun c:xz11 (/ kk lst i ent pts len)<br /> <br /> (setq lst (ssget '( (0 . "polyline") (8 . "0,sjw")) ) )<br /> (setq i 0)<br /> <br /> (setq kk (ssadd))<br /> (while  (< i (sslength lst))<br /> <br /> (setq ent (ssname lst i))<br /> <br /> (setq pts (vxs ent))<br />   (setq len (length pts))<br /> <br /> (if (< len 3) (ssadd ent kk)) ;;;选择节点少于3个的三维多段线<br /> <br /> <br /> (setq i (+ i 1))<br />   <br />   <br />   )<br /> <br /> (sssetfirst nil kk)<br />   <br />   )

skg123

那个大神能 把下图中，选中的多段线范围内边面积求出，那就厉害了。

CASS自带有表面积计算功能，处理的方法是下图多段线内在生成很多小三角，再计算面积。

我们编程可以用海伦公式计算单个三角的面积，累计也行。

编程用comand 命令调用CASS的表面功能，只能循环4次，批量处理超过4次就现在了使用。

czb203

有更新吗?楼主？

树櫴希德

2. GreenWood(181976640) 2015-8-4 16:18:15
   
3. @树櫴希德
   
4. ;;查找并删除角度较小的三角网
   
5. (defun c:tt(/ ss i en lens)
   
6.   (if (and (setq ss(ssget '((0 . "POLYLINE")(8 . "TIN"))))
   
7.            (> (sslength ss) 0)
   
8.            (setq i 0)
   
9.           )
   
10.     (while (setq en(ssname ss i))
    
11.       (setq lens (vlens en)
    
12.             lens (vl-sort lens '<)
    
13.             )
    
14.       (if (< (/ (car lens) (last lens)) 0.01);修改这里0.001~~~
    
15.        (entdel en)
    
16.        )
    
17.       (setq i (1+ i))
    
18.     )
    
19.    )
    
20. )
    
21. ；；；；；；；；；；；；；；；；；；
    
22. GreenWood(181976640) 2015-8-4 16:08:21
    
23. 那特么更简单了
    
24. (defun c:tt(/)
    
25.    (prompt "三角形中心(我不知道是什么心，反正在里面就是了)")
    
26.     (setq ent(car (entsel)))
    
27.     (if (= (vlax-curve-getEndParam ent) 3.0)
    
28.       (progn
    
29.        (setq pt1 (vlax-curve-getPointAtParam ent 1.0)
    
30.              pt2 (vlax-curve-getPointAtParam ent 2.0)
    
31.              pt3 (vlax-curve-getPointAtParam ent 3.0)
    
32.             )
    
33.         (setq pt (mapcar '(lambda (x y z) (/ (+ x y z) 3.0)) pt1 pt2 pt3))
    
34.         (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 5)))
    
35.       )
    
36.     )
    
37.    (princ)
    
38. );end defun
    

GreenWood(181976640) 2015-8-4 16:18:15<br /> @树櫴希德 <br /> ;;查找并删除角度较小的三角网<br /> (defun c:tt(/ ss i en lens)<br />   (if (and (setq ss(ssget '((0 . "POLYLINE")(8 . "TIN"))))<br />            (> (sslength ss) 0)<br />            (setq i 0)<br />           )<br />     (while (setq en(ssname ss i))<br />       (setq lens (vlens en)<br />             lens (vl-sort lens '<)<br />             )<br />       (if (< (/ (car lens) (last lens)) 0.01);修改这里0.001~~~<br />        (entdel en)<br />        )<br />       (setq i (1+ i))<br />     )<br />    )<br /> )<br /> ；；；；；；；；；；；；；；；；；；<br /> GreenWood(181976640) 2015-8-4 16:08:21<br /> 那特么更简单了<br /> (defun c:tt(/)<br />    (prompt "三角形中心(我不知道是什么心，反正在里面就是了)")<br />     (setq ent(car (entsel)))<br />     (if (= (vlax-curve-getEndParam ent) 3.0)<br />       (progn<br />        (setq pt1 (vlax-curve-getPointAtParam ent 1.0)<br />              pt2 (vlax-curve-getPointAtParam ent 2.0)<br />              pt3 (vlax-curve-getPointAtParam ent 3.0)<br />             )<br />         (setq pt (mapcar '(lambda (x y z) (/ (+ x y z) 3.0)) pt1 pt2 pt3))<br />         (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 5)))<br />       )<br />     )<br />    (princ)<br /> );end defun<br />

newbuser

作者真乃测绘接的创新研究型人才啊，占个沙发先。只要你一出作品，我肯定光顾。不错，很实用的东西。

spp_wall

厉害！！！！

树櫴希德

2. (defun tt (lst / a l1)
   
3. (setq l1 nil
   
4.         l1 (list (list (car lst)))
   
5.         lst (cdr lst)
   
6. )
   
7. (while lst
   
8.         (setq a (car lst)
   
9.                 lst (cdr lst)
   
10.         )
    
11.         (if (= 1 (- a (caar l1)))
    
12.                 (setq l1 (cons (cons a (car l1)) (cdr l1)))
    
13.                 (setq l1 (cons (list a) l1))
    
14.         )
    
15. )       
    
16. (reverse (mapcar 'reverse l1))
    
17. )
    
18. (setq lis'(1 2 3 4 5   11  20 21 22 23 24))
    
19. 
    
20. 命令: (tt lis)
    
21. ((1 2 3 4 5) (11) (20 21 22 23 24))

(defun tt (lst / a l1)<br /> (setq l1 nil<br />         l1 (list (list (car lst)))<br />         lst (cdr lst)<br /> )<br /> (while lst<br />         (setq a (car lst)<br />                 lst (cdr lst)<br />         )<br />         (if (= 1 (- a (caar l1)))<br />                 (setq l1 (cons (cons a (car l1)) (cdr l1)))<br />                 (setq l1 (cons (list a) l1))<br />         )<br /> )        <br /> (reverse (mapcar 'reverse l1))<br /> )<br /> (setq lis'(1 2 3 4 5   11  20 21 22 23 24))<br /> <br /> 命令: (tt lis)<br /> ((1 2 3 4 5) (11) (20 21 22 23 24))

gzxl

czb203

太牛逼了你

树櫴希德

2. 
   
3. 
   
4. 
   
5. (defun c:tt11 ( / lst ent pts pt demj zmj i) ;求平均数
   
6. (setq lst (ssget '((0 . "text,mtext") (1 . "*[0-9]*")   )   )  )
   
7.   
   
8. (setq i 0)
   
9. (setq zmj 0.000)
   
10.   
    
11. (while  (< i (sslength lst))
    
12. 
    
13. (setq ent (ssname lst i))
    
14. 
    
15. 
    
16. 
    
17.   
    
18. 
    
19.   (setq demj (atof(cdr (assoc 1 (entget ent)))))
    
20.   
    
21.   
    
22. 
    
23.   
    
24.   
    
25.   
    
26. (setq zmj(+ zmj demj))
    
27. 
    
28. (setq i (+ i 1))
    
29.   
    
30.   
    
31.   )
    
32. (entmake (list (cons 0  "TEXT") (cons 1 (strcat "总和"(rtos zmj 2 3) "平均数" (rtos (/ zmj i) 2 3) )) (cons 10 (getpoint "\请输入总和插入点"))
    
33.                (cons 40 3)
    
34.                (cons 8 "总和")
    
35.                ))
    
36. (print zmj)
    
37.   (print (/ zmj i))
    
38.   (princ)
    
39. 
    
40. )

<br /> <br /> <br /> (defun c:tt11 ( / lst ent pts pt demj zmj i) ;求平均数<br /> (setq lst (ssget '((0 . "text,mtext") (1 . "*[0-9]*")   )   )  )<br />   <br /> (setq i 0)<br /> (setq zmj 0.000)<br />   <br /> (while  (< i (sslength lst))<br /> <br /> (setq ent (ssname lst i))<br /> <br /> <br /> <br />   <br /> <br />   (setq demj (atof(cdr (assoc 1 (entget ent)))))<br />   <br />   <br /> <br />   <br />   <br />   <br /> (setq zmj(+ zmj demj))<br /> <br /> (setq i (+ i 1))<br />   <br />   <br />   )<br /> (entmake (list (cons 0  "TEXT") (cons 1 (strcat "总和"(rtos zmj 2 3) "平均数" (rtos (/ zmj i) 2 3) )) (cons 10 (getpoint "\请输入总和插入点"))<br />                (cons 40 3)<br />                (cons 8 "总和")<br />                ))<br /> (print zmj)<br />   (print (/ zmj i))<br />   (princ)<br /> <br /> )

llsheng_73

树櫴希德 发表于 2015-8-7 23:50

1. (defun c:tt11 ( / p zmj i) ;求平均数
   
2.   (if(setq i -1 zmj 0
   
3.            lst(ssget '((0 . "text,mtext") (1 . "*[0-9]*")))
   
4.            p(getpoint "\n请指定总和插入点"))
   
5.     (entmake(list'(0 . "TEXT")
   
6.                  (cons 1(strcat"总和"
   
7.                                (rtos(repeat(sslength lst)
   
8.                                       (setq i(1+ i)
   
9.                                             zmj(+(atof(cdr (assoc 1 (entget (ssname lst i)))))zmj)))2 3)
   
10.                                "平均数"(rtos(/ zmj(1+ i))2 3)))
    
11.                  (cons 10 p)
    
12.                  '(40 . 3)
    
13.                  '(8 . "总和"))))
    
14.   )

(defun c:tt11 ( / p zmj i) ;求平均数<br />   (if(setq i -1 zmj 0<br />            lst(ssget '((0 . "text,mtext") (1 . "*[0-9]*"))) <br />            p(getpoint "\n请指定总和插入点"))<br />     (entmake(list'(0 . "TEXT")<br />                  (cons 1(strcat"总和"<br />                                (rtos(repeat(sslength lst)<br />                                       (setq i(1+ i)<br />                                             zmj(+(atof(cdr (assoc 1 (entget (ssname lst i)))))zmj)))2 3)<br />                                "平均数"(rtos(/ zmj(1+ i))2 3)))<br />                  (cons 10 p)<br />                  '(40 . 3)<br />                  '(8 . "总和"))))<br />   )

另外，事实上"A123.4Bc"也符合过滤条件(1 . "*[0-9]*")，也就是说想选中全数值文本得用别的过滤条件或者采用别的手段
         为了保证rtos最后一个参数起作用，需要设置系统变量DIMZIN

gzbccy

不知道后面的明码是干什么用的