Topic: Help: Calculate volume from contours

[mhy3sx]

Hi, I am using this code to calculate the volume from contours.
I want to do 2 updates to this code

1) This code is not calculate correct in 2 decimals the volume. Perhaps use the contour areas with more decimals.
2) I want the results to be in table like the attach file

Code - Auto/Visual Lisp: [Select]

1. (defun c:test   (/ _foo _rtos a b r s v)
2.   ;; RJP » 2021-09-17
3.   (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e)))))
4.   (defun _rtos (n) (rtos n 2 2))
5.   (cond ((and (setq s (ssget '((0 . "*polyline") (-4 . "&=") (70 . 1))))
6.               (setq s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
7.          )
8.          (setq s (mapcar '_foo s))
9.          (setq s (vl-sort s '(lambda (r j) (> (car r) (car j)))))
10.          (while (cadr s)
11.            (setq a (car s)
12.                  b (cadr s)
13.                  s (cdr s)
14.            )
15.            ;; Average of areas multiplied by height = volume
16.            (setq v
17.                   (* (/ (apply '+ (mapcar 'car (list a b))) 2) (abs (apply '- (mapcar 'cadr (list a b)))))
18.            )
19.  
20.            (princ (strcat "\n("
21.                           (_rtos (cadr a))
22.                           " - "
23.                           (_rtos (cadr b))
24.                           ") = "
25.                           (_rtos v) " m3"
26.                   )
27.            )
28.            (setq r (cons v r))
29.          )
30.          (princ (strcat "\nV = " (_rtos (apply '+ r))" m3"))
31.          (textscr)
32.         )
33.   )
34.   (princ)
35. )
36.  
37.  

Thanks

[mhy3sx]

How to round to 2 decimal this

Code - Auto/Visual Lisp: [Select]

1.   (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e))))
2.  

I try this but is not working

Code - Auto/Visual Lisp: [Select]

1.   (defun _foo (e) (list (rtos (vlax-curve-getarea e) (cdr (assoc 38 (entget e)))2 2)))
2.  

Thanks

[ronjonp]

Change the _RTOS function to a larger or smaller number to see more or less decimal places:

Code - Auto/Visual Lisp: [Select]

1. (defun _rtos (n) (rtos n 2 0-15))

[mhy3sx]

Hi ronjonp. If you see in the first post I already have

Code: [Select]

  (defun _rtos (n) (rtos n 2 2)) ; for 2 decimals


But if you see the test.dwg file the volumes are not correct, because in this line

Code: [Select]

  (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e))))

the area is calculated from the polyline with more than 2 decimals. See the calculations in test.dwg. So I want in every calculation to have 2 decimals.

Can you help?

Thanks

[ribarm]

Code - Auto/Visual Lisp: [Select]

1. ...
2. (defun _rtos (n) (rtos n 2 2))
3. (defun _foo (e) (list (_rtos (vlax-curve-getarea e)) (_rtos (cdr (assoc 38 (entget e)))))
4. ...
5.  

[mhy3sx]

Hi ribarm. I add your code but is not working. I have this error

Code: [Select]

Command: TEST
Select objects: Specify opposite corner: 6 found
Select objects:
; error: bad argument type: numberp: "712.46"


Code: [Select]

(defun c:test (/ _foo _rtos a b r s v)
  ;; RJP » 2021-09-17
  (defun _rtos (n) (rtos n 2 2))
  (defun _foo (e) (list (_rtos (vlax-curve-getarea e)) (_rtos (cdr (assoc 38 (entget e))))))
  (cond ((and (setq s (ssget '((0 . "*polyline") (-4 . "&=") (70 . 1))))
      (setq s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
)
(setq s (mapcar '_foo s))
(setq s (vl-sort s '(lambda (r j) (> (car r) (car j)))))
(while (cadr s)
   (setq a (car s)
b (cadr s)
s (cdr s)
   )
   ;; Average of areas multiplied by height = volume
   (setq v
  (* (/ (apply '+ (mapcar 'car (list a b))) 2) (abs (apply '- (mapcar 'cadr (list a b)))))
   )

   (princ (strcat "\n("
  (_rtos (cadr a))
  " - "
  (_rtos (cadr b))
  ") = "
  (_rtos v) " m3"
  )
   )
   (setq r (cons v r))
)
(princ (strcat "\nV = " (_rtos (apply '+ r))" m3"))
(textscr)
)
  )
  (princ)
)

Thanks

[mhy3sx]

Can any one explain me how to create a table and insert the results in raws and columns ?

Code: [Select]

(defun c:test2 (/ _foo _rtos a b r s v)
  ;; RJP » 2021-09-17
  (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e)))))
  (defun _rtos (n) (rtos n 2 2))
    (cond ((and (setq s (ssget '((0 . "*polyline") (-4 . "&=") (70 . 1))))
    (setq s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
)
(setq s (mapcar '_foo s))
(setq s (vl-sort s '(lambda (r j) (> (car r) (car j)))))
(while (cadr s)
   (setq a (car s)
b (cadr s)
s (cdr s)
   )
   ;; Average of areas multiplied by height = volume
   (setq v
  (* (/ (apply '+ (mapcar 'car (list a b))) 2) (abs (apply '- (mapcar 'cadr (list a b)))))
   )
           (setq ar
                 (/ (apply '+ (mapcar 'car (list a b))) 2)
           )
           (setq dh
                   (abs (apply '- (mapcar 'cadr (list a b))))
           )
     (princ (strcat "\n(" (_rtos (cadr a)) " - "  (_rtos (cadr b)) ")  " (_rtos ar) " m2   "  (_rtos dh) " m    "  (_rtos v) " m3" ))
   (setq r (cons v r))
)
(princ (strcat "\nV = " (_rtos (apply '+ r))" m3"))
(textscr)
)
  )
  (princ)
)

Thanks

[mhy3sx]

The idea is a table like attach image. I Need help to fill the columns A1, A2

Code - Auto/Visual Lisp: [Select]

1. (defun c:test2  (/ _foo _rtos a b r s v)
2.   ;; RJP » 2021-09-17
3.   (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e)))))
4.   (defun _rtos (n) (rtos n 2 2))
5.     (cond ((and (setq s (ssget '((0 . "*polyline") (-4 . "&=") (70 . 1))))
6.             (setq s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
7.          )
8.          (princ (strcat "\n                Calculate volume from contours                   " ))
9.          (princ (strcat "\n-----------------------------------------------------------------"))
10.          (princ (strcat "\nElevation    (A1+A2) x Dh x 0.50       Dh             V"))
11.          (setq s (mapcar '_foo s))
12.          (setq s (vl-sort s '(lambda (r j) (> (car r) (car j)))))
13.          (princ (strcat "\n-----------------------------------------------------------------"))
14.          (while (cadr s)
15.            (setq a (car s)
16.                  b (cadr s)
17.                  s (cdr s)               
18.            )
19.            ;; Average of areas multiplied by height = volume
20.            (setq v
21.                   (* (/ (apply '+ (mapcar 'car (list a b))) 2) (abs (apply '- (mapcar 'cadr (list a b)))))
22.            )
23.  
24.            (setq ar
25.                  (/ (apply '+ (mapcar 'car (list a b))) 2)
26.            )
27.            (setq dh
28.                    (abs (apply '- (mapcar 'cadr (list a b))))
29.            )
30.  
31.  
32.             (princ (strcat "\n(" (_rtos (cadr a)) " - "  (_rtos (cadr b)) ")  "   (_rtos ar) " m2   "  (_rtos dh) " m    "  (_rtos v) " m3" ))
33.            (setq r (cons v r))
34.          )
35.          (princ (strcat "\n-----------------------------------------------------------------"))
36.          (princ (strcat "\nV = " (_rtos (apply '+ r))" m3"))
37.          (textscr)
38.         )
39.   )
40.   (princ)
41. )
42.  

Perhaps is more correct like this

Code - Auto/Visual Lisp: [Select]

1.          (princ (strcat "\nElevation               A1            A2            Dh            (A1+A2) x Dh x 0.50           V"))
2.  

[ronjonp]

Hi ronjonp. If you see in the first post I already have

Code: [Select]

  (defun _rtos (n) (rtos n 2 2)) ; for 2 decimals


But if you see the test.dwg file the volumes are not correct, because in this line

Code: [Select]

  (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e))))

the area is calculated from the polyline with more than 2 decimals. See the calculations in test.dwg. So I want in every calculation to have 2 decimals.

Can you help?

Thanks

You are introducing rounding errors if you truncate to two decimals while adding up the total volume...

There are many rounding functions to be used, the best here: http://www.lee-mac.com/round.html

Try to incorporate that into the output not within the total calculation.

[ribarm]

Hi ribarm. I add your code but is not working. I have this error

Code: [Select]

Command: TEST
Select objects: Specify opposite corner: 6 found
Select objects:
; error: bad argument type: numberp: "712.46"


Code: [Select]

  (defun _foo (e) (princ (strcat (_rtos (vlax-curve-getarea e)) " " (_rtos (cdr (assoc 38 (entget e))))))


[BIGAL]

Example of make a table.

Code: [Select]

; make table example
; By Alan H info@alanh.com.au
; 2018

(defun c:ahmaketable (/ colwidth numcolumns numrows objtable rowheight sp vgad vgao vgms)
(vl-load-com)
(setq sp (vlax-3d-point (getpoint "pick a point for table")))


(Setq vgms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) ;

(setq numrows 5)
(setq numcolumns 5)
(setq rowheight 2.5)
(setq colwidth 60)
(setq objtable (vla-addtable vgms sp numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "DRAWING REGISTER"); TABLE TITLE
(vla-settext objtable 1 0 "DRAWING NUMBER")
(vla-settext objtable 1 1 "DRAWING TITLE")
(vla-settext objtable 1 2 "C")
(vla-settext objtable 1 3 "D")
(vla-settext objtable 1 4 "E")
(vla-settext objtable 2 0 "1")
(vla-settext objtable 3 0 "2")
(vla-settext objtable 4 0 "3")
(command "_zoom" "e")

(princ)
)Also

Code: [Select]

(vla-insertrows objtable  numrows rowheight 1)

[mhy3sx]

Ηι BIGAL . I read this example , but in this example we have 5 columns and 3 rows , if I am correct. In test2.lsp we don't know how many contours we have, because is not standard. I don't know how this example will work in test2.lsp

Thanks

[BIGAL]

You make the default header and 1st row plus 1 blank data row then use the INSERTROW function to keep adding a new row, you can then use the Vla-settext to add the data row by row.

The insertrow is inside a While etc whilst you read the contours. Just keep making (setq numrows (1+ numrows))

I have done like 100's of rows using this. No idea how many I need.

If you get into a big number of rows you need to turn off regen table as the rows are inserted then turn back on at end. Way faster.

[mhy3sx]

I try this . can any one help?

Code - Auto/Visual Lisp: [Select]

1. can any one help me to fix this code
2.  
3. [code=cadlisp-7]
4. (defun c:test2  (/ _foo _rtos a b r s v tbl)
5.   (defun _foo (e) (list (vlax-curve-getarea e) (cdr (assoc 38 (entget e)))))
6.   (defun _rtos (n) (rtos n 2 2))
7.   (setq tbl (vlax-make-safearray vlax-vbDouble (cons 1 6)))
8.  
9.   (cond ((and (setq s (ssget '((0 . "*polyline") (-4 . "&=") (70 . 1))))
10.               (setq s (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))
11.          )
12.          (setq s (mapcar '_foo s))
13.          (setq s (vl-sort s '(lambda (r j) (> (car r) (car j)))))
14.          
15.          (setq row 0)
16.          (vlax-for val s
17.            (setq a (car val)
18.                  b (cadr val)
19.            )
20.            
21.            ;; calculate the results
22.            (setq A1 (car a)
23.                  A2 (car b)
24.                  Dh (abs (- (cadr a) (cadr b)))
25.                  sum (* (+ A1 A2) Dh 0.50)
26.                  V (* A1 Dh 0.50)
27.            )
28.            
29.            ;; insert the results in table
30.            (vla-put-value tbl (vlax-make-safearray-index (list (setq row (1+ row)) 0)) A1)
31.            (vla-put-value tbl (vlax-make-safearray-index (list row 1)) A2)
32.            (vla-put-value tbl (vlax-make-safearray-index (list row 2)) Dh)
33.            (vla-put-value tbl (vlax-make-safearray-index (list row 3)) sum)
34.            (vla-put-value tbl (vlax-make-safearray-index (list row 4)) V)
35.          )
36.          
37.          ;; print table
38.          (princ "Elevation        A1            A2            Dh            (A1+A2) x Dh x 0.50        V")
39.          (setq row 0)
40.          (while (< (setq row (1+ row)) (vla-get-dim2 tbl 1))
41.            (setq A1 (vla-get-value tbl (vlax-make-safearray-index (list row 0)))
42.                  A2 (vla-get-value tbl (vlax-make-safearray-index (list row 1)))
43.                  Dh (vla-get-value tbl (vlax-make-safearray-index (list row 2)))
44.                  sum (vla-get-value tbl (vlax-make-safearray-index (list row 3)))
45.                  V (vla-get-value tbl (vlax-make-safearray-index (list row 4)))
46.            )
47.            (princ (strcat "\n" (_rtos A1) "         " (_rtos A2) "         " (_rtos Dh) "         " (_rtos sum) "         " (_rtos V)))
48.          )
49.          (princ)
50.   )
51. )
52.  
53.  

Thanks


[/code]

[mhy3sx]

Any options?

Thanks