;;; Cut & Fill by ymg ;

;;; Ground Works Calculate ;

```
```(defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol

intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1

ss2 totcut totfill txt txtlayer 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 *acdoc* (vla-endundomark *acdoc*))

(princ)

)

(setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")

varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)

)

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

(vla-startundomark *acdoc*)

(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 ;

)

(while (not (setq ** (princ "\nSelect Reference Polyline:")

ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))

)

)

(princ "\nYou Must Select a Polyline:")

)

(while (not (setq ** (princ "\nSelect Proposed Polyline:")

ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))

)

)

(princ "\nYou Must Select a Polyline:")

)

(setq pol1 (ssname ss1 0)

len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))

pol2 (ssname ss2 0)

len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))

sp1 (vlax-curve-getstartpoint pol1)

spe (vlax-curve-getendpoint pol1)

sp2 (if (vlax-curve-isClosed pol2)

(setq lst2 (listpol pol2)

disl (mapcar '(lambda (a) (distance sp1 a)) lst2)

** (plineorg pol2 (nth (vl-position (apply 'min disl) disl) lst2))

)

(vlax-curve-getstartpoint pol2)

)

dir (if ( (length intl) 1)

(progn

; Computing distance of intersections on each polyline ;

(setq dl1 (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)

dl2 (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)

)

; If both polyline are closed add first Intersection to end of list ;

; We also add a distance to each distances list ;

(if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))

(setq dl1 (append dl1 (list (+ (car dl1) len1)))

dl2 (append dl2 (list (+ (car dl2) len2)))

intl (append intl (list (car intl)))

dir (if (iscw_p (listpol pol1)) -1 1)

)

)

; Finding points at mid-distance between intersections on each polyline ;

; Calculating midpoint between mid-distance points to get an internal point;

; Creating a list of all these points plus the intersection points ;

(setq pm

(mapcar

'(lambda (a b c d e)

(list (midpoint

(setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))

(setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))

)

p1 p2 e

)

)

dl1 (cdr dl1) dl2 (cdr dl2) intl

)

)

(foreach i pm

(setq p (car i) ; Midpoint between p1 p2 ;

p0 (cadddr i) ; Intersection Point ;

p1 (cadr i) ; Midpoint of Intersections on Reference Polyline ;

p2 (caddr i) ; Midpoint of Intersections on Proposed Polyline ;

)

(if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear ;

(progn

(vl-cmdf "._-BOUNDARY" p "")

(setq are (vla-get-area (vlax-ename->vla-object (entlast)))

bnd (entlast)

)

(if (minusp (* (onside p2 p0 p1) dir))

(setq totfill (+ totfill are) hcol fillcol)

(setq totcut (+ totcut are) hcol cutcol)

)

(vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")

(entdel bnd)

)

)

)

(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...")

(defun midpoint (p1 p2)

(mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)

)

; onside by ymg ;

; Negative return, point is on left of v1->v2 ;

; Positive return, point is on right 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))

(- (* (- (cadr v1) y) (- (car v2) x)) (* (- (car v1) x) (- (cadr v2) y)))

)

; ;

; Is Polyline Clockwise by LeeMac ;

; ;

; Argument: l, Point List ;

; Returns: t, Polyline is ClockWise ;

; nil, Polyline is CounterClockWise ;

; ;

(defun iscw_p (l)

(if (equal (car l) (last l) 1e-8) (setq l (cdr 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 VLA-Object or two ENAME ;

;; obj1 - first VLA-Object ;

;; obj2 - second VLA-Object ;

;; mode - intersection mode (acExtendNone acExtendThisEntity ;

;; acExtendOtherEntity acExtendBoth) ;

;; Requires triplet ;

;; ;

(defun Intersections (obj1 obj2)

(or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))

(or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))

(triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))

)

;; ;

;; triplet, Separates a list into triplets of items. ;

;; ;

(defun triplet (l)

(if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))

)

(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 ymg (Simplified a Routine by Gile Chanteau ;

;; ;

;; Parameter: en, Entity Name or Object Name of Any Type of Polyline ;

;; ;

;; Returns: List of Points in Current UCS ;

;; ;

;; Notes: On Closed Polyline the Last Vertex is Same as First) ;

;; ;

(defun listpol (en / i l)

(repeat (setq i (fix (1+ (vlax-curve-getEndParam en))))

(setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))

)

)

;; plineorg by (gile) (Modified into a function by ymg) ;

;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/ ;

;; change-polyline-start-point/td-p/2154331 ;

;; ;

;; Function to modify origin of a closed polyline ;

;; ;

;; Arguments: ;

;; en : Ename or VLA-Object of a Closed Polyline. ;

;; pt : Point ;

;; ;

;; Returns: Point of Origin if successful, else nil. ;

;; ;

(defun plineorg (en pt / blst d1 d2 d3 n norm obj pa plst)

(if (= (type en) 'ENAME)

(setq obj (vlax-ename->vla-object en))

(setq obj en en (vlax-vla-object->ename obj))

)

;; bulgratio by (gile) ;

;; Returns a bulge which is proportional to a reference ;

;; Arguments : ;

;; b : the reference bulge ;

;; k : the ratio (between angles or arcs length) ;

(defun bulgratio (b k / a)

(setq a (atan b))

(/ (sin (* k a)) (cos (* k a)))

)

;; Sublist by (gile) ;

;; Returns a sublist similar to substr function. ;

;; lst : List from which sublist is to be extracted ;

;; idx : Index of Item at Start of sublist ;

;; len : Length of sublist or nil to return all items. ;

(defun sublist (lst n len / rtn)

(if (or (not len) (< (- (length lst) n) len))

(setq len (- (length lst) n))

)

(setq n (+ n len))

(repeat len

(setq rtn (cons (nth (setq n (1- n)) lst) rtn))

)

)

(if (and (= (vla-get-closed obj) :vlax-true)

(= (vla-get-objectname obj) "AcDbPolyline")

)

(progn

(setq plst (vlax-get obj 'coordinates)

norm (vlax-get obj 'normal)

pt (vlax-curve-getClosestPointTo en (trans pt 1 0))

pa (vlax-curve-getparamatpoint obj pt)

n (/ (length plst) 2)

)

(repeat n

(setq blst (cons (vla-getbulge obj (setq n (1- n))) blst))

)

(if (= pa (fix pa))

(setq n (fix pa)

plst (append (sublist plst (* 2 n) nil)

(sublist plst 0 (* 2 n))

)

blst (append (sublist blst n nil) (sublist blst 0 n))

)

(setq n (1+ (fix pa))

d3 (vlax-curve-getdistatparam en n)

d2 (- d3 (vlax-curve-getdistatpoint en pt))

d3 (- d3 (vlax-curve-getdistatparam en (1- n)))

d1 (- d3 d2)

pt (trans pt 0 (vlax-get obj 'normal))

plst (append (list (car pt) (cadr pt))

(sublist plst (* 2 n) nil)

(sublist plst 0 (* 2 n))

)

blst (append (list (bulgratio (nth (1- n) blst) (/ d2 d3)))

(sublist blst n nil)

(sublist blst 0 (1- n))

(list (bulgratio (nth (1- n) blst) (/ d1 d3)))

)

)

)

(vlax-put obj 'coordinates plst)

(repeat (setq n (length blst))

(vla-setbulge obj (setq n (1- n)) (nth n blst))

)

(trans pt 0 1)

)

nil

)

)

(c:cf)

Advertisements

```
```