Hatch Between two polylines

December 24, 2020

hello all;
I'm using the code bellow, but i need to click on almost 2000 road cross sections one by one, indeed that is time consuming.

it would be more general if the code can select all green lines at ones and then the red lines. mean that, if there be 2000 road cross sections for example; the code can select all cross sections and report a cut and fill file separately for each section (the same as AreaLabelV1-9.lsp of Mr.Lee Mac does)
appreciate if anyone can help me
tnx

;;; Cut & Fill by ymg ;
;;; ;
(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 (< (/ pi 2) (angle sp1 spe) (/ (* 3 pi) 2)) -1 1)
)
; Getting all the intersections between poly. ;
(setq intl (intersections pol1 pol2))
(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
)
)

Sign In

Hatch Between two polylines

Recommended Posts

Anis

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity