等高线计算土方，必须封闭

树櫴希德

等高线计算土方，必须封闭

1. ( defun c:dgxtf (  / lst lst1 dgj pt pzx pzx1 mj mj1 tj   )
   
2. 
   
3. (vl-load-com)
   
4. (alert "本图按照毫米为单位计算等高线土方")
   
5. (setq dgj (getreal "\n请输入等高距毫米："))
   
6. (prompt "\n请选择低的一组等高线")
   
7. 
   
8. (setq lst (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )
   
9. (prompt "\n请选择高的一组等高线")
   
10. 
    
11. (setq lst1 (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )
    
12. (setq pt(getpoint "\n请点击体积标注位置："))
    
13. ;选择集与对象名表互转
    
14. (defun cx-ss2en
    
15.   (ss / enlst)
    
16.   (cond
    
17.     ((= (type ss) 'PICKSET)
    
18.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
    
19.     )
    
20.     ((= (type ss) 'LIST)
    
21.       (setq enlst (ssadd))
    
22.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
23.     )
    
24.     ((='ename(type ss))
    
25.       (ssadd ss)
    
26.     )
    
27.   )
    
28. )
    
29. ;(entget(car(entsel))'("*"))
    
30. (setq pzx 0)
    
31. (foreach x (cx-ss2en lst)
    
32.       (setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;
    
33.     (setq pzx (+ mj pzx))
    
34.   (vla-put-color (vlax-ename->vla-object x) 20)
    
35.   )
    
36. (setq pzx1 0)
    
37. (foreach y (cx-ss2en lst1)
    
38.       (setq mj1 (vlax-curve-getArea (vlax-ename->vla-object y)) ) ;;;;
    
39.     (setq pzx1 (+ mj1 pzx1))
    
40.   (vla-put-color (vlax-ename->vla-object y) 223)
    
41.   )
    
42. 
    
43. (setq tj (/(*  (/ (+(expt (* pzx pzx1) 0.5) pzx pzx1 ) 3.0000)      dgj) 1000000000.0000) )
    
44. 
    
45.   ; 6、单行文本
    
46. (entmake (list '(0 . "TEXT") (cons 1 (rtos tj 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))
    
47. (princ)
    
48. 
    
49. )
    
50. 
    
51. ;;;;;;;;;;;;;;;;;;;;;;;
    
52. ( defun c:dgxtf1 (  / lst lst1 dgj pt pzx pzx1 mj mj1 tj  i )
    
53. 
    
54. (vl-load-com)
    
55. (alert "本图按照毫米为单位计算等高线土方")
    
56. (setq dgj (getreal "\n请输入等高距毫米："))
    
57. (prompt "\n请选择一组等高线")
    
58. (setq lst (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )
    
59. (setq pt(getpoint "\n请点击体积标注位置："))
    
60. (setq pzx '())
    
61.   (foreach x (cx-ss2en lst)
    
62.     (setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;
    
63.     (setq pzx (append (list mj) pzx))
    
64.    
    
65.     (vla-put-color (vlax-ename->vla-object x) 20)
    
66.      ) (setq pzx (vl-sort pzx '>) )
    
67.   (setq i 0)
    
68.   (setq pzx1 0)
    
69. 
    
70. (repeat   (-(length pzx) 1)
    
71.     (setq tj (/(*  (/ (+(expt (* (nth i pzx)  (nth (+ i 1) pzx) ) 0.5) (nth i pzx) (nth (+ i 1) pzx)  ) 3.0000) dgj) 1000000000.0000) )
    
72.      (setq pzx1 (+ tj pzx1))
    
73. (setq i (1+ i))
    
74.   )
    
75. 
    
76.   (entmake (list '(0 . "TEXT") '(8 . "zxtj")(cons 1 (rtos pzx1 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))
    
77. 
    
78. (princ )
    
79.   )

( defun c:dgxtf (  / lst lst1 dgj pt pzx pzx1 mj mj1 tj   )<br /> <br /> (vl-load-com)<br /> (alert "本图按照毫米为单位计算等高线土方")<br /> (setq dgj (getreal "\n请输入等高距毫米："))<br /> (prompt "\n请选择低的一组等高线")<br /> <br /> (setq lst (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )<br /> (prompt "\n请选择高的一组等高线")<br /> <br /> (setq lst1 (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )<br /> (setq pt(getpoint "\n请点击体积标注位置："))<br /> ;选择集与对象名表互转<br /> (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 /> ;(entget(car(entsel))'("*"))<br /> (setq pzx 0)<br /> (foreach x (cx-ss2en lst)<br />       (setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;<br />     (setq pzx (+ mj pzx))<br />   (vla-put-color (vlax-ename->vla-object x) 20)<br />   )<br /> (setq pzx1 0)<br /> (foreach y (cx-ss2en lst1)<br />       (setq mj1 (vlax-curve-getArea (vlax-ename->vla-object y)) ) ;;;;<br />     (setq pzx1 (+ mj1 pzx1))<br />   (vla-put-color (vlax-ename->vla-object y) 223)<br />   )<br /> <br /> (setq tj (/(*  (/ (+(expt (* pzx pzx1) 0.5) pzx pzx1 ) 3.0000)      dgj) 1000000000.0000) )<br /> <br />   ; 6、单行文本<br /> (entmake (list '(0 . "TEXT") (cons 1 (rtos tj 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))<br /> (princ)<br /> <br /> )<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;<br /> ( defun c:dgxtf1 (  / lst lst1 dgj pt pzx pzx1 mj mj1 tj  i )<br /> <br /> (vl-load-com)<br /> (alert "本图按照毫米为单位计算等高线土方")<br /> (setq dgj (getreal "\n请输入等高距毫米："))<br /> (prompt "\n请选择一组等高线")<br /> (setq lst (ssget '((0 . "LWPOLYLINE,SPLINE")    )   )  )<br /> (setq pt(getpoint "\n请点击体积标注位置："))<br /> (setq pzx '())<br />   (foreach x (cx-ss2en lst)<br />     (setq mj (vlax-curve-getArea (vlax-ename->vla-object x)) ) ;;;;<br />     (setq pzx (append (list mj) pzx))<br />     <br />     (vla-put-color (vlax-ename->vla-object x) 20)<br />      ) (setq pzx (vl-sort pzx '>) )<br />   (setq i 0)<br />   (setq pzx1 0)<br /> <br /> (repeat   (-(length pzx) 1)<br />     (setq tj (/(*  (/ (+(expt (* (nth i pzx)  (nth (+ i 1) pzx) ) 0.5) (nth i pzx) (nth (+ i 1) pzx)  ) 3.0000) dgj) 1000000000.0000) )<br />      (setq pzx1 (+ tj pzx1))<br /> (setq i (1+ i))<br />   )<br /> <br />   (entmake (list '(0 . "TEXT") '(8 . "zxtj")(cons 1 (rtos pzx1 2 3)) (cons 10 pt)(cons 62 3) (cons 40 1000)))<br /> <br /> (princ )<br />   )