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