Calculate Cut and Fill levels

October 22, 2009

Dear all, attach here the sample drawing showing two levels in

layer "AS" (as built levels) and "OGL" (original ground levels) all in grid line . I need to get the different value for OGL minus AS and place it as the same position to be present as a individual drawing, if the figure is not much then manual or by Microsoft excel it can be done, problem is that im facing with around 15000 point and above.

Hope some one can help me .:(i manually using transfer to Microsoft excel and transfer back to autocad seem not a good idea.

Hope some guru here can help.

thanks in advance.

OGL-AS.dwg

October 22, 2009

Something like this?? I've put the text on layer 0, just specify a different layer so you can select it and move it to another drawing.

Load and type TXTHTS to run.

(defun c:txtHts (/ ss1 ss2 i j en en2 ht1 ht2 ht3 pt1 pt2 flag)

 (setq ss1 (ssget "_X" '((0 . "TEXT")(8 . "AS")))
   ss2 (ssget "_X" '((0 . "TEXT")(8 . "OGL")))
   i -1)
 (while (setq en (ssname ss1 (setq i (1+ i))))
   (setq ht1 (atof (cdr (assoc 1 (entget en))))
     pt1 (cdr (assoc 10 (entget en)))
     j -1
     flag nil)
   (while (and (not flag)
       (setq en2 (ssname ss2 (setq j (1+ j)))))
     (setq pt2 (cdr (assoc 10 (entget en2))))
     (if (and (equal (car pt1) (car pt2) 0.5)
          (equal (cadr pt1) (cadr pt2) 0.5))
   (setq flag T)
   )
     )
   (if flag
     (progn
   (setq ht2 (atof (cdr (assoc 1 (entget en2)))))
   (setq ht3 (- ht2 ht1))
   (entmake (list (cons 0 "TEXT")
              (cons 1 (rtos ht3 2 2))
              (cons 8 "[b][color=Blue]0[/color][/b]")
              (cons 10 pt1)
              (cons 40 0.2)
              (cons 100 "AcDbEntity")
              (cons 100 "AcDbText")
              )
        )
   )(princ "\nOGL Text Not Found.")
     )
   )
 (princ)
 )

steve

October 23, 2009

Dear steve1, thanks for help, but i found that the value coming out is not correct as OGL-AS ? is that i miss out some thing?

October 23, 2009

steve1, i found that if i take only one point and try it work perfect, but if i try two or lots of point the result become not correct.pls help

October 23, 2009

Dear steve1, the lisp seem like taken one OGL and minus all the AS, not individual OGL minus individual AS ...

October 23, 2009

Ah sorry, a minor flaw. I updated the above post. Try it out and let me know,

Steve

October 23, 2009

What i can say steve1 WOW! it work great!! but can we have a choice to select the portion to process, because i have more than 15000 point it take a long time to process when all in one time. many thanks to you Steve1

October 23, 2009

What i can say steve1 WOW! it work great!! but can we have a choice to select the portion to process, because i have more than 15000 point it take a long time to process when all in one time. many thanks to you Steve1

Strange, it shouldn't take that long...

If you want to select just a portion try this:

(defun c:txtHts (/ ss i j en en2 ht1 ht2 ht3 pt1 pt2 flag)
 (princ "\nSelect Text: ")
 (setq ss (ssget '((0 . "TEXT")(8 . "AS,OGL")))
   i -1)
 (while (setq en (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 8 (entget en))) "AS")
     (progn
   (setq ht1 (atof (cdr (assoc 1 (entget en))))
         pt1 (cdr (assoc 10 (entget en)))
         j -1
         flag nil)
   (while (and (not flag)
           (setq en2 (ssname ss (setq j (1+ j)))))
     (if (eq (cdr (assoc 8 (entget en2))) "OGL")
       (progn
         (setq pt2 (cdr (assoc 10 (entget en2))))
         (if (and (equal (car pt1) (car pt2) 0.5)
              (equal (cadr pt1) (cadr pt2) 0.5))
       (setq flag T)
       )
         )
       )
     )
   (if flag
     (progn
       (setq ht2 (atof (cdr (assoc 1 (entget en2)))))
       (setq ht3 (- ht2 ht1))
       (entmake (list (cons 0 "TEXT")
              (cons 1 (rtos ht3 2 2))
              (cons 8 "0")
              (cons 10 pt1)
              (cons 40 0.2)
              (cons 100 "AcDbEntity")
              (cons 100 "AcDbText")
              )
            )
       )(princ "\nOGL Text Not Found.")
     )
   )
     )
   )
 (princ)
 )

October 23, 2009

I don't know what to say Steve, billion thanks to you!! ( It take some times to process all the figure together because it's really a lots, so i think it's normal )

October 23, 2009

You're welcome.

October 23, 2009

I was bored and the wife is sick...

;;; Calculate Cut/Fill of text values in drawing
;;; Alan J. Thompson, 10.22.09
(defun c:CutFill (/ _Ins2Pnt _Sort #SS #OGL #AS #Total)
 (vl-load-com)
 (setq _Ins2Pnt (lambda (x) (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint x))))
       _Sort    (lambda (l)
                  (vl-sort l '(lambda (x y) (> (distance (car x) '(0 0 0)) (distance (car y) '(0 0 0)))))
                ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (cond
   ((setq #SS (ssget "_X" '((0 . "TEXT") (8 . "OGL,AS"))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ((eq (vla-get-layer x) "OGL")
         (setq #OGL (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #OGL))
        )
        ((eq (vla-get-layer x) "AS")
         (setq #AS (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #AS))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (mapcar '(lambda (n c) (vla-put-color (vla-add (vla-get-layers *AcadDoc*) n) c))
            '("CUT" "FILL" "TOTAL")
            '(1 6 2)
    ) ;_ mapcar
    (mapcar '(lambda (o a / #Amt)
               (if (minusp (setq #Amt (- (cdr o) (cdr a))))
                 (AT:MText (car a) (rtos (abs #Amt) 2 2) 0 "CUT" 7)
                 (AT:MText (car a) (rtos #Amt 2 2) 0 "FILL" 7)
               ) ;_ if
             ) ;_ lambda
            (_Sort #OGL)
            (_Sort #AS)
    ) ;_ mapcar
    (setq #OGL   (apply '+ (mapcar 'cdr #OGL))
          #AS    (apply '+ (mapcar 'cdr #AS))
          #Total (strcat "TOTALS\\POGL: "
                         (rtos #OGL 2 2)
                         "\\PAS: "
                         (rtos #AS 2 2)
                         "\\P------------\\PDIFFERENCE: "
                         (rtos (- #OGL #AS) 2 2)
                 ) ;_ strcat
    ) ;_ setq
    (AT:MText (trans (cadr (grread T 15 0)) 1 0) #Total 0 "TOTAL" 1)
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

I got a little carried away.

I was lazy and used my MText subroutine:

;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;;             1 or nil= TopLeft
;;;             2= TopCenter
;;;             3= TopRight
;;;             4= MiddleLeft
;;;             5= MiddleCenter
;;;             6= MiddleRight
;;;             7= BottomLeft
;;;             8= BottomCenter
;;;             9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
                #Space #Insertion #Object
               )
 (or #Width (setq #Width 0))
 (or *AcadDoc*
     (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
 ) ;_ or
 (setq #Space     (if (or (eq acmodelspace
                              (vla-get-activespace *AcadDoc*)
                          ) ;_ eq
                          (eq :vlax-true (vla-get-mspace *AcadDoc*))
                      ) ;_ or
                    (vla-get-modelspace *AcadDoc*)
                    (vla-get-paperspace *AcadDoc*)
                  ) ;_ if
       #Insertion (cond
                    ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
                    ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
                    (T nil)
                  ) ;_ cond
 ) ;_ setq
 ;; create MText object
 (setq #Object (vla-addmtext #Space #Insertion #Width #String))
 ;; change layer, if applicable
 (and #Layer
      (tblsearch "layer" #Layer)
      (vla-put-layer #Object #Layer)
 ) ;_ and
 ;; change justification & match insertion point with new justification
 (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
        (vla-put-attachmentpoint #Object #Justification)
        (vla-move #Object
                  (vla-get-InsertionPoint #Object)
                  #Insertion
        ) ;_ vla-move
       )
 ) ;_ cond
 #Object
) ;_ defun

October 23, 2009

Actually, since I have it create the values on separate layers, might be a good idea to clean them before doing the calculations:

;;; Calculate Cut/Fill of text values in drawing
;;; Alan J. Thompson, 10.22.09
(defun c:CutFill (/ _Ins2Pnt _Sort #SS #OGL #AS #Total)
 (vl-load-com)
 (setq _Ins2Pnt (lambda (x) (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint x))))
       _Sort    (lambda (l)
                  (vl-sort l '(lambda (x y) (> (distance (car x) '(0 0 0)) (distance (car y) '(0 0 0)))))
                ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (cond
   ((setq #SS (ssget "_X" '((8 . "CUT,FILL,TOTAL"))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (vl-catch-all-apply 'vla-delete (list x)))
    (vl-catch-all-apply 'vla-delete (list #SS))))
 (cond
   ((setq #SS (ssget "_X" '((0 . "TEXT") (8 . "OGL,AS"))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ((eq (vla-get-layer x) "OGL")
         (setq #OGL (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #OGL))
        )
        ((eq (vla-get-layer x) "AS")
         (setq #AS (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #AS))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (mapcar '(lambda (n c) (vla-put-color (vla-add (vla-get-layers *AcadDoc*) n) c))
            '("CUT" "FILL" "TOTAL")
            '(1 6 2)
    ) ;_ mapcar
    (mapcar '(lambda (o a / #Amt)
               (if (minusp (setq #Amt (- (cdr o) (cdr a))))
                 (AT:MText (car a) (rtos (abs #Amt) 2 2) 0 "CUT" 7)
                 (AT:MText (car a) (rtos #Amt 2 2) 0 "FILL" 7)
               ) ;_ if
             ) ;_ lambda
            (_Sort #OGL)
            (_Sort #AS)
    ) ;_ mapcar
    (setq #OGL   (apply '+ (mapcar 'cdr #OGL))
          #AS    (apply '+ (mapcar 'cdr #AS))
          #Total (strcat "TOTALS\\POGL: "
                         (rtos #OGL 2 2)
                         "\\PAS: "
                         (rtos #AS 2 2)
                         "\\P------------\\PDIFFERENCE: "
                         (rtos (- #OGL #AS) 2 2)
                 ) ;_ strcat
    ) ;_ setq
    (AT:MText (trans (cadr (grread T 15 0)) 1 0) #Total 0 "TOTAL" 1)
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

I ran this on over 5000 points and it ripped through it in no time.

October 23, 2009

alanjt, Thanks for your time, its really very fast(amazing), but when i random check the result lot of it not correct..is that anything i must beware?( the total off difference is really a good idea ) and seem we have the total difference ,is that possible to get the quantity of volume for cut and fill with total cut and fill area also ?

October 23, 2009

alanjt, Thanks for your time, its really very fast(amazing), but when i random check the result lot of it not correct..is that anything i must beware?( the total off difference is really a good idea ) and seem we have the total difference ,is that possible to get the quantity of volume for cut and fill with total cut and fill area also ?

Can you process a drawing (with my routine) and post it? On everyone of my test, it worked perfectly.

Not sure if I know how to calculate the volume, since I think I'd need to be able to interpolate a 'surface'. Hmm...

October 23, 2009

Ok , here i attach the drawing file after process.

just to confirm, 1st step i load both mtext and cutfill .lsp.

then i type the command cutfill, wait for the result right?

OGL-AS 1.dwg

October 23, 2009

Ok , here i attach the drawing file after process.

just to confirm, 1st step i load both mtext and cutfill .lsp.

then i type the command cutfill, wait for the result right?

;;; Calculate Cut/Fill of text values in drawing
;;; Alan J. Thompson, 10.22.09
(defun c:CutFill (/ _Ins2Pnt _FlatDist _Sort #SS #OGL #AS #Total)
 (vl-load-com)
 (setq _Ins2Pnt (lambda (x) (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint x))))
       _FlatDist (lambda (x y) (distance (list (car x) (cadr x)) (list (car y) (cadr y))))
       _Sort    (lambda (l)
                  (vl-sort l '(lambda (x y) (> (_FlatDist (car x) '(0 0 0)) (_FlatDist (car y) '(0 0 0)))))
                ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (cond
   ((setq #SS (ssget "_X" '((8 . "CUT,FILL,TOTAL"))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (vl-catch-all-apply 'vla-delete (list x)))
    (vl-catch-all-apply 'vla-delete (list #SS))))
 (cond
   ((setq #SS (ssget "_X" '((0 . "TEXT") (8 . "OGL,AS"))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ((eq (vla-get-layer x) "OGL")
         (setq #OGL (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #OGL))
        )
        ((eq (vla-get-layer x) "AS")
         (setq #AS (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #AS))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (mapcar '(lambda (n c) (vla-put-color (vla-add (vla-get-layers *AcadDoc*) n) c))
            '("CUT" "FILL" "TOTAL")
            '(1 6 2)
    ) ;_ mapcar
    (mapcar '(lambda (o a / #Amt)
               (if (minusp (setq #Amt (- (cdr o) (cdr a))))
                 (AT:MText (car a) (rtos (abs #Amt) 2 2) 0 "CUT" 7)
                 (AT:MText (car a) (rtos #Amt 2 2) 0 "FILL" 7)
               ) ;_ if
             ) ;_ lambda
            (_Sort #OGL)
            (_Sort #AS)
    ) ;_ mapcar
    (setq #OGL   (apply '+ (mapcar 'cdr #OGL))
          #AS    (apply '+ (mapcar 'cdr #AS))
          #Total (strcat "TOTALS\\POGL: "
                         (rtos #OGL 2 2)
                         "\\PAS: "
                         (rtos #AS 2 2)
                         "\\P------------\\PDIFFERENCE: "
                         (rtos (- #OGL #AS) 2 2)
                 ) ;_ strcat
    ) ;_ setq
    (AT:MText (trans (cadr (grread T 15 0)) 1 0) #Total 0 "TOTAL" 1)
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

Try this one...

October 23, 2009

Still cant get all correct.

October 23, 2009

Still cant get all correct.

I know, I'm getting the same 10 wrong everytime. I'll need to try something else for the sorting portion, but for now, I'm going to bed. I'll play with it tomorrow. However, Steve's does work, I was just trying to make something a little more generic.

October 23, 2009

I know, I'm getting the same 10 wrong everytime. I'll need to try something else for the sorting portion, but for now, I'm going to bed. I'll play with it tomorrow. However, Steve's does work, I was just trying to make something a little more generic.

Ya, your right..no problem. anyhow thanks to you first:D

October 23, 2009

Ya, your right..no problem. anyhow thanks to you first:D

Ok, I lied, but I got it to work. I revised my sorting method. Here's a TEST version that will draw a connecting line (I'll remove this when we're satisfied). I still have a problem (as does Steve) if there are an uneven amount of OSL and AS text objects. I've got an idea how to get around this, but I really don't feel like iterating through the list tonight.

On a side note, I coded out the procedure to place the text below the AS text, but there's something crazy with your coordinates (everthing is off by 90°) and it just screws up the text placement.

This one will take a bit longer, but it's creating a joining line segment (just for debugging purposes, I'll remove it).

Give this a try and I'm really going to bed....

(defun CutFill (/ _Ins2Pnt _FlatDist _Sort #Count #Choice #SS #OGL #AS #Total)
 (vl-load-com)
 (setq _FlatPnt (lambda (x) (list (car x) (cadr x)))
       _Ins2Pnt  (lambda (x) (_FlatPnt (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint x)))))
       _FlatDist (lambda (x y) (distance (list (car x) (cadr x)) (list (car y) (cadr y))))
       _Sort     (lambda (l)
                   (vl-sort l
                            '(lambda (x y) (> (_FlatDist (car x) '(0 0 0)) (_FlatDist (car y) '(0 0 0))))
                   ) ;_ vl-sort
                 ) ;_ lambda
       #Count    0
 ) ;_ setq

 ;(setq _Sort2 (lambda (l) (vl-sort l '(lambda (x y) (>= 0.5 (_FlatDist (car x) (car y)))))))

 (setq _Sort (lambda (l) (vl-sort l '(lambda (x y) (> (apply '+ (_FlatPnt (car x))) (apply '+ (_FlatPnt (car y))))))))

 
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (initget 0 "Yes No")
 (cond
   ((and (or (setq #Choice (getkword "\nErase originals? [Yes/No] <No>: "))
             (setq #Choice "No")
         ) ;_ or
         (if (eq #Choice "No")
           (setq #SS (ssget "_X" '((0 . "TEXT") (8 . "OGL,AS"))))
           (setq #SS (ssget "_X" '((0 . "TEXT,MTEXT,LINE") (8 . "OGL,AS,CUT,FILL,TOTAL,LINE"))))
         ) ;_ if
    ) ;_ and
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ((eq (vla-get-layer x) "OGL")
         (setq #OGL   (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #OGL)
               #Count (1+ #Count)
         ) ;_ setq
        )
        ((eq (vla-get-layer x) "AS")
         (setq #AS    (cons (cons (_Ins2Pnt x) (atof (vla-get-TextString x))) #AS)
               #Count (1+ #Count)
         ) ;_ setq
        )
        ((and (eq #Choice "Yes") (vl-position (vla-get-layer x) '("CUT" "FILL" "TOTAL" "LINE")))
         (vl-catch-all-apply 'vla-delete (list x))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (mapcar '(lambda (n c) (vla-put-color (vla-add (vla-get-layers *AcadDoc*) n) c))
            '("CUT" "FILL" "TOTAL" "LINE")
            '(1 6 2 4)
    ) ;_ mapcar
    (mapcar '(lambda (o a / #Pnt #Amt)
               (setq #Pnt (polar (list (car (car a)) (cadr (car a)))
                                 (angle (car o) (car a))
                                 (_FlatDist (car o) (car a))
                          ) ;_ polar
               ) ;_ setq
               (if (minusp (setq #Amt (- (cdr o) (cdr a))))
                 (AT:MText (car a) (rtos (abs #Amt) 2 2) 0 "CUT" 7)
                 (AT:MText (car a) (rtos #Amt 2 2) 0 "FILL" 7)
               ) ;_ if
               (entmakex (list '(0 . "LINE")
                               '(8 . "LINE")
                               (cons 10 (car a))
                               (cons 11 (car o))))
             ) ;_ lambda
            (_Sort #OGL)
            (_Sort #AS)
    ) ;_ mapcar
    (setq #OGL   (apply '+ (mapcar 'cdr #OGL))
          #AS    (apply '+ (mapcar 'cdr #AS))
          #Total (strcat "TOTALS\\POGL: "
                         (rtos #OGL 2 2)
                         "\\PAS: "
                         (rtos #AS 2 2)
                         "\\P------------\\PDIFFERENCE: "
                         (rtos (- #OGL #AS) 2 2)
                 ) ;_ strcat
    ) ;_ setq
    (AT:MText (trans (cadr (grread T 15 0)) 1 0) #Total 0 "TOTAL" 1)
    (princ (strcat "\n" (itoa #Count) " processed."))
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
)

Call it with (CutFill)

I also added an option to Erase originals. :wink:

Sign In

Calculate Cut and Fill levels

Recommended Posts

jason tay

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

SteveK

jason tay

jason tay

jason tay

SteveK

jason tay

SteveK

jason tay

SteveK

alanjt

alanjt

jason tay

alanjt

jason tay

alanjt

jason tay

alanjt

jason tay

alanjt

Join the conversation

Tutorials

Forums

Activity