Author Topic: need help earth work cross section area calculation  (Read 494 times)

0 Members and 1 Guest are viewing this topic.

Sudipta2020

  • Mosquito
  • Posts: 10
need help earth work cross section area calculation
« on: August 28, 2020, 04:34:15 AM »
Is there any lisp to calculate cross section cut and fill area (along with hatch) with excel output 

BIGAL

  • Swamp Rat
  • Posts: 516
  • 30 + years of using Autocad
Re: need help earth work cross section area calculation
« Reply #1 on: September 01, 2020, 10:34:09 PM »
Its pretty straight forward a semi manual method using ssget with correct filter can get hatches and then get areas as you only have CUT and Fill pretty straight forward. Pick chainage text then select screen area of hatches write a csv file Chainage,Cut,fill.

Do you know anything about lisp ?

Google export hatch area should be out there.

A man who never made a mistake never made anything

HOSNEYALAA

  • Newt
  • Posts: 53
Re: need help earth work cross section area calculation
« Reply #2 on: September 02, 2020, 04:39:35 AM »
https://www.theswamp.org/index.php?topic=45305.15
 

@ ymg

Code: [Select]
;;; Cut & Fill      by ymg                                                    ;
;;;                                                                           ;
;;; Will return incorrect results if polyline are self-crossing.              ;
 
 
 
(defun c:cf (/ *acaddoc* ar cutcol cw cwi dm1 dm2 dp11 dp12 dp21 dp22 fillcol
               fuzz hatchcol i intl objpol1 objpol2 p p1 p2 pm0 pm1 pm2 pol1
               pol2 ss1 ss2 totcut totfill txt txtlayer valid varl)
     
   (vl-load-com)
 
   (defun *error* (msg)
        (mapcar 'eval varl)
        (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
           (princ (strcat "\nError: " msg))
        )
        (and *AcadDoc* (vla-endundomark *AcadDoc*))
        (princ)
   )
     
   (setq varl '("OSMODE" "CMDECHO" "DIMZIN")
         varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
   )
   
   (or *AcadDoc*
        (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
   )
     
   (vla-startundomark *AcadDoc*)
 
   (setvar 'CMDECHO 0)
   (setvar 'DIMZIN  0)
   (setvar 'OSMODE  0)
     
 
  (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                      ;
        totcut 0  totfill 0  ; Total Cut and Total Fill                       ;
          txtlayer "Text"    ; Name of Layer for Cut and Fill Values          ;
         
  )     
  (princ "\nSelect Reference Polyline:")
     (setq ss1 (ssget "_:S"))
     (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
          (princ "\nYou Must Select a Polyline:")
          (setq ss1 (ssget "_:S"))
     )
 
 (princ "\nSelect Proposed Polyline:")
     (setq ss2 (ssget "_:S"))
     (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
          (princ "\nYou Must Select a Polyline:")
          (setq ss2 (ssget "_:S"))
     )
     
 
  (setq pol1 (ssname ss1 0) objpol1 (vlax-ename->vla-object pol1)
        pol2 (ssname ss2 0) objpol2 (vlax-ename->vla-object pol2)
          cw (if (iscw_p (listpol pol1)) 1 -1)
  )
 
 
  ; Getting all the intersections between poly.                               ;
 
  (setq intl (intersections objpol1 objpol2)) 
 
 
  ; If polyline is closed add first Intersection to end of list               ;
     
  (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
     (setq intl (append intl (list (car intl))))
  )
 
  ; Insure that Intersection List goes same direction as Reference Polyline.  ;
  (setq cwi (if (iscw_p intl) 1 -1))
  (if (/= cw cwi) (setq intl (reverse intl)))
 
  (setq  p1 (car intl)
       dp11 (getdistoncurve pol1 p1)
       dp21 (getdistoncurve pol2 p1)
          i 1
  )
  (repeat (- (length intl) 1)
     (setq valid t           
              p2 (nth i intl)
            dp12 (getdistoncurve pol1 p2)
            dp22 (getdistoncurve pol2 p2)
             dm1 (/ (+ dp11 dp12) 2)                       
             dm2 (/ (+ dp21 dp22) 2)             
             pm1 (getptoncurve pol1 dm1)             
             pm2 (getptoncurve pol2 dm2)
             pm0 (mapcar '/ (mapcar '+ pm1 pm2) '(2. 2.))  ; Internal Point   ;
     )
     (if (> (distance pm1 pm2) 0.00001)
        (progn     
            (vl-cmdf "._-BOUNDARY" pm0 "")
            (setq ar (vla-get-area (vlax-ename->vla-object (entlast))))
            (entdel (entlast))
            (if (minusp (* (onside pm2 p1 pm1) cw))             
               (setq totcut  (+ totcut  ar) hatchcol  cutcol)
               (setq totfill (+ totfill ar) hatchcol fillcol)
            )
            ;(vl-cmdf "._POINT" pm0 "")
            (vl-cmdf "._-HATCH" "_P" "SOLID" "_CO" hatchcol pm0 "")         
        )
     )
     (setq   p1 p2
           dp11 dp12
           dp21 dp22
              i (1+ i)
     )
  )
     
  (if valid
      (progn
          (setq   p (cadr (grread nil 13 0))
                txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
          )       
          (entmakex (list
                      (cons 0 "MTEXT")
                      (cons 100 "AcDbEntity")
                      (cons 8 txtlayer)
                      (cons 100 "AcDbMText")
                      (cons 10 p)               
                      (cons 40 3.0)
                      (cons 1 txt)
                    )
          )         
 
          (command "_MOVE" (entlast) "" p pause)
      )
      (Alert "Not Enough Intersections To Process !")
  )
     
  (*error* nil)
     
)
 
(princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
(princ "\nCF to start...")
 
 
 
; onside        by ymg                                                        ;
; Negative return, point is on right of v1->v2                                ;
; Positive return, point is on left  of v1->v2                                ;
;        0 return, point is smack on the vector.                              ;
;                                                                             ;
 
(defun onside (p v1 v2 / x y)
    (setq x (car p) y (cadr p))
    (- (* (- (car  v1) x) (- (cadr v2) y)) (* (- (cadr v1) y) (- (car  v2) x)))   
)
 
; is the polyline  clockwise.                by LeeMac                        ;
(defun iscw_p (l)     
    (minusp
        (apply '+
            (mapcar
                (function
                    (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                )
                l (cons (last l) l)
            )
        )
    )
)
 
;;****************************************************************************;
;; Return list of intersection(s) between two objects                         ;
;; obj1 - first VLA-Object                                                    ;
;; obj2 - second VLA-Object                                                   ;
;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
;;                                acExtendOtherEntity acExtendBoth)           ;
;;****************************************************************************;
     
(defun Intersections (obj1 obj2)
   (defun tupl3 (l) (if l (cons (list (car l) (cadr l) (caddr l))(tupl3 (cdddr l)))))
   (tupl3 (vlax-invoke obj1 'intersectwith obj2 acExtendNone))           
)
 
 
(defun getdistoncurve (e p)
   (vlax-curve-getDistatParam e
        (vlax-curve-getparamatpoint e
             (vlax-curve-getclosestpointto e p)
        )     
   )         
)
 
(defun getptoncurve (e d)
   (vlax-curve-getpointatparam e (vlax-curve-getparamatdist e d))
)
 
;;; listpol   by Gille Chanteau                                               ;
;;; Returns the vertices list of any type of polyline (WCS coordinates)       ;
;;;                                                                           ;
;;; Argument                                                                  ;
;;; en, a polyline (ename or vla-object)                                      ;
 
(defun listpol (en / i p l) 
  (setq i (vlax-curve-getEndParam en) i (if (vlax-curve-IsClosed en) i (1+ i)))       
  (while (setq p (vlax-curve-getPointAtParam en (setq i (1- i))))
      (setq l (cons (trans p 0 1 ) l))
  )
)

Sudipta2020

  • Mosquito
  • Posts: 10
Re: need help earth work cross section area calculation
« Reply #3 on: September 02, 2020, 09:17:09 AM »
already I saw this lisp file ita a great work but sometimes it not work in Autocad 2018 or higher.

HOSNEYALAA

  • Newt
  • Posts: 53
Re: need help earth work cross section area calculation
« Reply #4 on: September 02, 2020, 09:43:03 AM »
I am working on CAD 2021
You are before you start work
Command: Flatten all elements of the drawing

Due to the running area of the intersection of the POLYLINES which must be at the same height

So it gets INTERSECTION   " Command ._-BOUNDARY"





Sudipta2020

  • Mosquito
  • Posts: 10
Re: need help earth work cross section area calculation
« Reply #5 on: September 05, 2020, 05:26:46 AM »
ITS NOT WORKING

BIGAL

  • Swamp Rat
  • Posts: 516
  • 30 + years of using Autocad
Re: need help earth work cross section area calculation
« Reply #6 on: September 05, 2020, 08:57:51 PM »
Hosneyalaa think you went down wrong path, very simple just get the hatch area on the 2 layers per each title block. Manually would be pick chainage text as its not an attribute would make life much easier, then just window the hatch area.

In an automated sense would get the block "graph" get a bounding box and insertion point, find text chainage value and get hatch areas write a csv. If chainages not in order sort in excel.

No reason why not do volume calc at same time.

Need some time. May rain later today.

Ps did $7 million dollar project getting hatch areas so not hard just discipline.
A man who never made a mistake never made anything

HOSNEYALAA

  • Newt
  • Posts: 53
Re: need help earth work cross section area calculation
« Reply #7 on: September 06, 2020, 01:59:55 AM »
HI BIGAL

please
  Correcting the error in the code is why HATCHING does not work



Code: [Select]
;;; Cut & Fill      by ymg                                                    ;
;;;                                                                           ;
;;; Will return incorrect results if polyline are self-crossing.              ;
   ;;;  https://www.theswamp.org/index.php?topic=45305.15

(defun c:cf ( / *error* onside iscw_p intersections getdistoncurve getptoncurve listpol
                *acaddoc* ar cutcol cw cwi dm1 dm2 dp11 dp12 dp21 dp22 fillcol
                fuzz hatchcol i intl objpol1 objpol2 p p1 p2 pm0 pm1 pm2 pol1
                pol2 ss1 ss2 totcut totfill txt txtlayer valid varl ALL DESCRIPTION F FF PP VARL)

  (vl-load-com)


 


 
  (defun *error* ( msg )
    (mapcar 'eval varl)
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
          (princ (strcat "\nError: " msg))
    )
    (and *AcadDoc* (vla-endundomark *AcadDoc*))
    (princ)
  )

  ; onside        by ymg                                                        ;
  ; Negative return, point is on right of v1->v2                                ;
  ; Positive return, point is on left  of v1->v2                                ;
  ;        0 return, point is smack on the vector.                              ;
  ;                                                                             ;

  (defun onside ( p v1 v2 / x y )
     (setq x (car p) y (cadr p))
     (- (* (- (car  v1) x) (- (cadr v2) y)) (* (- (cadr v1) y) (- (car  v2) x)))   
  )

  ; is the polyline  clockwise.                by LeeMac                        ;
  (defun iscw_p ( l )   
    (minusp
      (apply '+
        (mapcar
          (function
            (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
          )
          l (cons (last l) l)
        )
      )
    )
  )

  ;;****************************************************************************;
  ;; Return list of intersection(s) between two objects                         ;
  ;; obj1 - first VLA-Object                                                    ;
  ;; obj2 - second VLA-Object                                                   ;
  ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  ;;                                acExtendOtherEntity acExtendBoth)           ;
  ;;****************************************************************************;

  (defun Intersections ( obj1 obj2 / tupl3 )
    (defun tupl3 (l) (if l (cons (list (car l) (cadr l) (caddr l)) (tupl3 (cdddr l)))))
    (tupl3 (vlax-invoke obj1 'intersectwith obj2 acExtendNone))         
  )

  (defun getdistoncurve ( e p )
    (vlax-curve-getDistatParam e
      (vlax-curve-getparamatpoint e
        (vlax-curve-getclosestpointto e p)
      )
    )
  )

  (defun getptoncurve ( e d )
    (vlax-curve-getpointatparam e (vlax-curve-getparamatdist e d))
  )

  ;;; listpol   by Gille Chanteau                                               ;
  ;;; Returns the vertices list of any type of polyline (WCS coordinates)       ;
  ;;;                                                                           ;
  ;;; Argument                                                                  ;
  ;;; en, a polyline (ename or vla-object)                                      ;

  (defun listpol ( en / i p l )
    (setq i (vlax-curve-getEndParam en) i (if (vlax-curve-IsClosed en) i (1+ i)))      
    (while (setq p (vlax-curve-getPointAtParam en (setq i (1- i))))
      (setq l (cons (trans p 0 1) l))
    )
  )

  (setq varl '("OSMODE" "CMDECHO" "DIMZIN")
        varl (mapcar (function (lambda ( a ) (list 'setvar a (getvar a)))) varl)
  )

  (or *AcadDoc*
    (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
  )

  (vla-startundomark *AcadDoc*)

  (setvar 'CMDECHO 0)
  (setvar 'DIMZIN  0)
  (setvar 'OSMODE  0)

  (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                      ;
        totcut 0  totfill 0  ; Total Cut and Total Fill                       ;
        txtlayer  "Text"     ; Name of Layer for Cut and Fill Values          ;
  )
  (setq qflg NIL)
  (WHILE (not qflg)

    (setq description (getstring "\nSTATION to be set: "))


   
  (princ "\nSelect Reference Polyline:")
  (setq ss1 (ssget "_+.:E:S"))
  (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
    (princ "\nYou Must Select a Polyline:")
    (setq ss1 (ssget "_+.:E:S"))
  )

  (princ "\nSelect Proposed Polyline:")
  (setq ss2 (ssget "_+.:E:S"))
  (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
    (princ "\nYou Must Select a Polyline:")
    (setq ss2 (ssget "_+.:E:S"))
  )

  (setq pol1 (ssname ss1 0) objpol1 (vlax-ename->vla-object pol1)
        pol2 (ssname ss2 0) objpol2 (vlax-ename->vla-object pol2)
          cw (if (iscw_p (listpol pol1)) 1 -1)
  )

  ; Getting all the intersections between poly.                               ;

  (setq intl (intersections objpol1 objpol2)) 

  ; If polyline is closed add first Intersection to end of list               ;

  (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
    (setq intl (append intl (list (car intl))))
  )

  ; Insure that Intersection List goes same direction as Reference Polyline.  ;
  (setq cwi (if (iscw_p intl) 1 -1))
  (if (/= cw cwi) (setq intl (reverse intl)))

  (setq  p1 (car intl)
       dp11 (getdistoncurve pol1 p1)
       dp21 (getdistoncurve pol2 p1)
          i 1
  )
  (repeat (- (length intl) 1)
    (setq valid t     
             p2 (nth i intl)
           dp12 (getdistoncurve pol1 p2)
           dp22 (getdistoncurve pol2 p2)
            dm1 (/ (+ dp11 dp12) 2)                       
            dm2 (/ (+ dp21 dp22) 2)           
            pm1 (getptoncurve pol1 dm1)    
            pm2 (getptoncurve pol2 dm2)
            pm0 (mapcar '/ (mapcar '+ pm1 pm2) '(2. 2.))  ; Internal Point   ;
    )

    (if (> (distance pm1 pm2) 0.00001)
      (progn     
        (vl-cmdf "_.-BOUNDARY" "_none" pm0 "")
        (setq ar (vla-get-area (vlax-ename->vla-object (setq arOB(entlast)))))
(command "-HATCH" "Properties" "ANSI31" "1.0" "0" "Advanced" "Island" "Yes" "Style" "Normal" "" "Select" arOB "" "")
        (entdel (entlast))
        (if (minusp (* (onside pm2 p1 pm1) cw))             
          (setq totcut  (+ totcut  ar) hatchcol  cutcol)
          (setq totfill (+ totfill ar) hatchcol fillcol)
        )
        ;(vl-cmdf "_.POINT" "_none" pm0 "")
           
      )
    )




   
    (setq   p1 p2
          dp11 dp12
          dp21 dp22
             i (1+ i)
    )
  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (if valid
    (progn
      (setq p (cadr (grread nil 13 0))
            txt (strcat "{\\C3;Fill = " (rtos totfill 2 2) " sq.m\\P\\C1;Cut = " (rtos totcut  2 2) " sq.m}")
      )
      (setq ALL (CONS (LIST description totcut totfill) ALL))
     
      (entmake
        (list
          (cons 0 "MTEXT")
          (cons 100 "AcDbEntity")
          (cons 8 txtlayer)
          (cons 100 "AcDbMText")
          (cons 10 p)
          (cons 40 (getvar 'textsize))
          (cons 1 txt)
        )
      )
      (command "_MOVE" (entlast) "" p "\\")
     
    )
    (alert "Not Enough Intersections To Process !")
  )
(cond ( (not qflg)
              (initget "Yes No")
              (setq ans (cond ( (getkword "\nSelection Finished [Yes/No] <No>")) ("No")))
              (if (= ans "Yes") (setq qflg T))
            ))
  (setq ss1 NIL)
  (setq ss2 NIL)
  (setq description  NIL)
);;;;WHILE

(if (and ALL
             (setq fF (getfiled "" "" "csv" 1))
             (setq f (open fF "w"))
         (setq PP (LIST "Chainage" "Cutting Area" "Filling Area" ))
         (write-line (apply 'strcat (mapcar 'strcat PP '(";" ";" ";" ""))) f)
             
        )
        (progn
            (repeat (setq i (length ALL))
                (setq i (1- i))
                (setq PP (LIST (car (NTH I ALL)) (rtos(caDr (NTH I ALL))) (rtos(caDDr (NTH I ALL))) ))
       
             
;;;                (write-line (apply 'strcat (mapcar 'strcat (mapcar 'rtos p) '("," "," ""))) f)
              (write-line (apply 'strcat (mapcar 'strcat PP '(";" ";" ";" ""))) f)
            )
            (close f)
          (startapp "explorer" fF)
        )
    )
 


 
  (*error* nil)

)

(princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
(princ "\nCF to start...")
(princ)






BIGAL

  • Swamp Rat
  • Posts: 516
  • 30 + years of using Autocad
Re: need help earth work cross section area calculation
« Reply #8 on: September 06, 2020, 07:18:53 PM »
This needs more about finding each title block and pulling the chainage text out but shows how simple to get hatch area, relies on hatch being created correctly.

Just window one section as a test
Code: [Select]
(setq ss (ssget (list (cons 0 "hatch")(cons 8 "Cut,Fill"))))
(repeat (setq x (sslength ss))
  (setq hat (vlax-ename->vla-object (ssname SS (setq x (- x 1)))))
  (setq lay (vla-get-layer hat))
  (setq area (vla-get-area hat))
  (alert (strcat "area is " (rtos area 2 1) " on Layer " lay))
  )
A man who never made a mistake never made anything

Sudipta2020

  • Mosquito
  • Posts: 10
Re: need help earth work cross section area calculation
« Reply #9 on: September 07, 2020, 03:40:50 AM »
HI HOSNEYALAA,
I change in this lisp for hatching, please check it. but in this lisp area output getting wrong after selection one section, cut & fill value added in next section. Please correct this point

HOSNEYALAA

  • Newt
  • Posts: 53
Re: need help earth work cross section area calculation
« Reply #10 on: September 07, 2020, 01:30:23 PM »
hi
Code: [Select]
;;; Cut & Fill      by ymg                                                    ;
;;;                                                                           ;
;;; Will return incorrect results if polyline are self-crossing.              ;
   ;;;  https://www.theswamp.org/index.php?topic=45305.15

(defun c:cf ( / *error* onside iscw_p intersections getdistoncurve getptoncurve listpol
                *acaddoc* ar CUTLAYER cw cwi dm1 dm2 dp11 dp12 dp21 dp22 FILLLAYER
                fuzz HATCHLAYER i intl objpol1 objpol2 p p1 p2 pm0 pm1 pm2 pol1
                pol2 ss1 ss2 totcut totfill txt txtlayer valid varl ALL DESCRIPTION F FF PP VARL)

(defun LAYER()
 (command "_.Layer" "_Make" "CUT" "_Color" "12" "" "LType" "Continuous" "" "")
 (command "_.Layer" "_Make" "FILL" "_Color" "92" "" "LType" "Continuous" "" "")
 (princ)
 )

  (vl-load-com)
 
  (defun *error* ( msg )
    (mapcar 'eval varl)
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
          (princ (strcat "\nError: " msg))
    )
    (and *AcadDoc* (vla-endundomark *AcadDoc*))
    (princ)
  )

  ; onside        by ymg                                                        ;
  ; Negative return, point is on right of v1->v2                                ;
  ; Positive return, point is on left  of v1->v2                                ;
  ;        0 return, point is smack on the vector.                              ;
  ;                                                                             ;

  (defun onside ( p v1 v2 / x y )
     (setq x (car p) y (cadr p))
     (- (* (- (car  v1) x) (- (cadr v2) y)) (* (- (cadr v1) y) (- (car  v2) x)))   
  )

  ; is the polyline  clockwise.                by LeeMac                        ;
  (defun iscw_p ( l )   
    (minusp
      (apply '+
        (mapcar
          (function
            (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
          )
          l (cons (last l) l)
        )
      )
    )
  )

  ;;****************************************************************************;
  ;; Return list of intersection(s) between two objects                         ;
  ;; obj1 - first VLA-Object                                                    ;
  ;; obj2 - second VLA-Object                                                   ;
  ;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
  ;;                                acExtendOtherEntity acExtendBoth)           ;
  ;;****************************************************************************;

  (defun Intersections ( obj1 obj2 / tupl3 )
    (defun tupl3 (l) (if l (cons (list (car l) (cadr l) (caddr l)) (tupl3 (cdddr l)))))
    (tupl3 (vlax-invoke obj1 'intersectwith obj2 acExtendNone))         
  )

  (defun getdistoncurve ( e p )
    (vlax-curve-getDistatParam e
      (vlax-curve-getparamatpoint e
        (vlax-curve-getclosestpointto e p)
      )
    )
  )

  (defun getptoncurve ( e d )
    (vlax-curve-getpointatparam e (vlax-curve-getparamatdist e d))
  )

  ;;; listpol   by Gille Chanteau                                               ;
  ;;; Returns the vertices list of any type of polyline (WCS coordinates)       ;
  ;;;                                                                           ;
  ;;; Argument                                                                  ;
  ;;; en, a polyline (ename or vla-object)                                      ;

  (defun listpol ( en / i p l )
    (setq i (vlax-curve-getEndParam en) i (if (vlax-curve-IsClosed en) i (1+ i)))      
    (while (setq p (vlax-curve-getPointAtParam en (setq i (1- i))))
      (setq l (cons (trans p 0 1) l))
    )
  )

  (setq varl '("OSMODE" "CMDECHO" "DIMZIN")
        varl (mapcar (function (lambda ( a ) (list 'setvar a (getvar a)))) varl)
  )

  (or *AcadDoc*
    (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
  )

  (vla-startundomark *AcadDoc*)

  (setvar 'CMDECHO 0)
  (setvar 'DIMZIN  0)
  (setvar 'OSMODE  0)

  (setq CUTLAYER "CUT"    ; Name of Layer for Cut  hatch Values          ;
         FILLLAYER "FILL"    ; Name of Layer for Fill  hatch Values          ;
        totcut 0  totfill 0  ; Total Cut and Total Fill                       ;
          txtlayer "TEXT"    ; Name of Layer for Cut and Fill Values          ;
  )
  (setq qflg NIL)
  (WHILE (not qflg)

    (setq description (getstring "\nSTATION to be set: "))


   
  (princ "\nSelect Reference Polyline:")
  (setq ss1 (ssget "_+.:E:S"))
  (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
    (princ "\nYou Must Select a Polyline:")
    (setq ss1 (ssget "_+.:E:S"))
  )

  (princ "\nSelect Proposed Polyline:")
  (setq ss2 (ssget "_+.:E:S"))
  (while  (not (wcmatch (cdr (assoc 0 (entget (ssname ss1 0)))) "*POLYLINE"))
    (princ "\nYou Must Select a Polyline:")
    (setq ss2 (ssget "_+.:E:S"))
  )

  (setq pol1 (ssname ss1 0) objpol1 (vlax-ename->vla-object pol1)
        pol2 (ssname ss2 0) objpol2 (vlax-ename->vla-object pol2)
          cw (if (iscw_p (listpol pol1)) 1 -1)
  )

  ; Getting all the intersections between poly.                               ;

  (setq intl (intersections objpol1 objpol2))

  ; If polyline is closed add first Intersection to end of list               ;

  (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
    (setq intl (append intl (list (car intl))))
  )

  ; Insure that Intersection List goes same direction as Reference Polyline.  ;
  (setq cwi (if (iscw_p intl) 1 -1))
  (if (/= cw cwi) (setq intl (reverse intl)))

  (setq  p1 (car intl)
       dp11 (getdistoncurve pol1 p1)
       dp21 (getdistoncurve pol2 p1)
          i 1
  )
  (repeat (- (length intl) 1)
    (setq valid t     
             p2 (nth i intl)
           dp12 (getdistoncurve pol1 p2)
           dp22 (getdistoncurve pol2 p2)
            dm1 (/ (+ dp11 dp12) 2)                       
            dm2 (/ (+ dp21 dp22) 2)           
            pm1 (getptoncurve pol1 dm1)    
            pm2 (getptoncurve pol2 dm2)
            pm0 (mapcar '/ (mapcar '+ pm1 pm2) '(2. 2.))  ; Internal Point   ;
    )

    (if (> (distance pm1 pm2) 0.00001)
      (progn     
        (vl-cmdf "_.-BOUNDARY" "_none" pm0 "")
        (setq ar (vla-get-area (vlax-ename->vla-object (setq arOB(entlast)))))
        (entdel (entlast))
        (if (minusp (* (onside pm2 p1 pm1) cw))             
          (setq totcut  (+ totcut  ar) HATCHLAYER  CUTLAYER)
          (setq totfill (+ totfill ar) HATCHLAYER FILLLAYER)
        )
        ;(vl-cmdf "_.POINT" "_none" pm0 "")
        (vl-cmdf "._-HATCH" "_P" "SOLID""_LA" hatchlayer pm0 "")   
      )
    )




   
    (setq   p1 p2
          dp11 dp12
          dp21 dp22
             i (1+ i)
    )
  );;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (if valid
    (progn
      (setq p (cadr (grread nil 13 0))
            txt (strcat "{\\C3;Fill = " (rtos totfill 2 2) " sq.m\\P\\C1;Cut = " (rtos totcut  2 2) " sq.m}")
      )
      (setq ALL (CONS (LIST description totcut totfill) ALL))
       (setq totcut 0)
    (setq totfill 0)
     
      (entmake
        (list
          (cons 0 "MTEXT")
          (cons 100 "AcDbEntity")
          (cons 8 txtlayer)
          (cons 100 "AcDbMText")
          (cons 10 p)
          (cons 40 (getvar 'textsize))
          (cons 1 txt)
        )
      )
      (command "_MOVE" (entlast) "" p "\\")
     
    )
    (alert "Not Enough Intersections To Process !")
  )
(cond ( (not qflg)
              (initget "Yes No")
              (setq ans (cond ( (getkword "\nSelection Finished [Yes/No] <No>")) ("No")))
              (if (= ans "Yes") (setq qflg T))
            ))
   
  (setq ss1 NIL)
  (setq ss2 NIL)
  (setq description  NIL)
);;;;WHILE

(if (and ALL
             (setq fF (getfiled "" "" "csv" 1))
             (setq f (open fF "w"))
         (setq PP (LIST "Chainage" "Cutting Area" "Filling Area" ))
         (write-line (apply 'strcat (mapcar 'strcat PP '(";" ";" ";" ""))) f)
             
        )
        (progn
            (repeat (setq i (length ALL))
                (setq i (1- i))
                (setq PP (LIST (car (NTH I ALL)) (rtos(caDr (NTH I ALL))) (rtos(caDDr (NTH I ALL))) ))
       
             
;;;                (write-line (apply 'strcat (mapcar 'strcat (mapcar 'rtos p) '("," "," ""))) f)
              (write-line (apply 'strcat (mapcar 'strcat PP '(";" ";" ";" ""))) f)
            )
            (close f)
          (startapp "explorer" fF)
        )
    )
 


 
  (*error* nil)

)

(princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
(princ "\nCF to start...")
(princ)




Sudipta2020

  • Mosquito
  • Posts: 10
Re: need help earth work cross section area calculation
« Reply #11 on: September 08, 2020, 01:34:01 AM »
Thanks Hosneyalaa

HOSNEYALAA

  • Newt
  • Posts: 53
Re: need help earth work cross section area calculation
« Reply #12 on: September 08, 2020, 10:55:28 AM »
THANK YOU