HI BIGAL
please
Correcting the error in the code is why HATCHING does not work
;;; 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)