Area Between Two Polylines

[alfacsys]

Hi I am a beginner in LISP Programming. If some body can help me to write a lisp to calculate "Total Upper Area" and "Total Lower Area" between two polylines which intersects each other in many places. See attached Drawing as a reference. Many Thanks in advance

[marko_ribar]

To do this using lisp, it will be pretty hard job... My opinion, and I suggest you use it is to use commands : "BPOLY" for creating area islands by picking point inside area of two intersecting boundary polylines; and after that to use command "AREA" -> Add option -> Select Objects... For better precision use "UNITS" command to set decimal precision of calculated areas...

Hope this helps for now..., M.R.

[alfacsys]

Thank you Marko for your quick replay.
This is what iam doing now. There are several drawings, may be more than 100, to do this practice and may miss some area. So i thought of making a small routine by saying in SSGET the to polylines.

I am using the following code and iam not much happy with it. If i could do some thing to avoid the PICKING, it is not only time saving also avoid data missing.

(DEFUN c:cf ()
  (setvar "cmdecho" 0)
  (setq totfil 0)
  (setq totcut 0)
  (SETQ ERASESET (ssadd))
  (command "regenall")
  (while
    (setq filpt (getpoint "\nPick FILL Area internal Point"))
     (command "-boundary" "a" "o" "p" "" filpt "")

     (setq cfens (entlast))
     (if cfens
       (progn
	 (setq chk (cdr (assoc 0 (entget cfens))))
	 (if (= chk "LWPOLYLINE")
	   (progn
	     (setq chk1 (cdr (assoc 70 (entget cfens))))
	     (if (= (rem chk1 2) 1)
	       (progn
		 (command "area" "e" cfens)
		 (command "chprop" cfens "" "c" 7 "")
		 (setq larea (getvar "area"))
		 (if larea
		   (setq totfil (+ totfil larea))
		 ) ;_ end of if
	       ) ;_ end of progn
	     ) ;_ end of if
	     (SSADD cfens ERASESET)
	   ) ;_ end of progn
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of while
  (while
    (setq cutpt (getpoint "\nPick CUT Area internal Point"))
     (command "-boundary" "a" "o" "p" "" cutpt "")

     (setq cfens (entlast))
     (if cfens
       (progn
	 (setq chk (cdr (assoc 0 (entget cfens))))
	 (if (= chk "LWPOLYLINE")
	   (progn
	     (setq chk1 (cdr (assoc 70 (entget cfens))))
	     (if (= (rem chk1 2) 1)
	       (progn
		 (command "area" "e" cfens)
		 (command "chprop" cfens "" "c" 2 "")
		 (setq larea (getvar "area"))
		 (if larea
		   (setq totcut (+ totcut larea))
		 ) ;_ end of if
	       ) ;_ end of progn
	     ) ;_ end of if
	     (SSADD cfens ERASESET)
	   ) ;_ end of progn
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
  ) ;_ end of while
  (setq fillarea (rtos totfil 2 3))
  (setq cutarea (rtos totcut 2 3))
  (if ERASESET
    (command "erase" ERASESET "")
  ) ;_ end of if

;;;I am using a Title Block with attributes
;;;And i need to update that with new Total areas

  (setq
    ssblk (ssget "x"
		 (list (cons 0 "insert") (cons 2 "A3_Title_EW_Cont4"))
	  ) ;_ end of ssget
  ) ;_ end of setq
  (setq ttlblk (ssname ssblk 0))
  (setq attrblock (entnext ttlblk))
  (while (/= (cdr (assoc 0 (entget attrblock))) "SEQEND")
    (setq attrent (entget attrblock))
    (if	(= (cdr (assoc 0 attrent)) "ATTRIB")
      (progn
	(setq atvalue (assoc 1 attrent))
	(cond
	  ((= (cdr (assoc 2 attrent)) "CUT")
	   (setq newattrib (cons 1 cutarea))
	   (setq su (subst newattrib atvalue attrent))
	   (entmod su)
	   (entupd attrblock)
	  )
	  ((= (cdr (assoc 2 attrent)) "CHAINAGE")
	   (setq ex_chainage atvalue)
	  )
	  ((= (cdr (assoc 2 attrent)) "FILL")
	   (setq newattrib (cons 1 fillarea))
	   (setq su (subst newattrib atvalue attrent))
	   (entmod su)
	   (entupd attrblock)
	  )
	) ;_ end of cond
      ) ;_ end of progn
    ) ;_ end of if
    (setq attrblock (entnext attrblock))
  ) ;_ end of while

;;;;and send this Areas to to a CSV file

  (setq dwgpre_plt (getvar "dwgprefix"))
  (setq fnm (strcat dwgpre_plt "Corrected Fill Vol.csv"))
  (setq opn (open fnm "a"))
  (setq txt (strcat (cdr ex_chainage) "," cutarea "," fillarea))
  (write-line txt opn)
  (setq opn (close opn))
  (princ)
) ;_ end of DEFUN

[marko_ribar]

Try this... It may help you :

;;=====================================
;;  return a list of intersect points  
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
  (if (not (vl-catch-all-error-p
             (setq iplist (vl-catch-all-apply
                            'vlax-safearray->list
                            (list
                              (vlax-variant-value
                                (vla-intersectwith obj1 obj2 acextendnone)
                              ))))))
    iplist
  )
)

(defun get_iplstpts (obj1 obj2 / iplst iplstn pt iplstpts)
(setq iplst (get_interpts obj1 obj2))
(setq iplstn (length iplst))
	(repeat (/ iplstn 3)
	(setq pt (list (car iplst) (cadr iplst) (caddr iplst)) )
		(repeat 3
		(setq iplst (cdr iplst))
		)
	(setq iplstpts (cons pt iplstpts))
	)
(setq iplstpts (reverse iplstpts))
)

(defun c:areabtw2pl ( / oscmd fuzz ent1 obj1 obj2 obj1u obj1d ptu ptd ptlst ptlstn pt1 param1 pt2 param2 pt param ssup ssdwn ent k auu au add ad)
(vl-load-com)
(vl-cmdf "ucs" "w")
(setq oscmd (getvar "osmode"))
(setvar "luprec" 8)
(setvar "osmode" 0)
(setq ent1 (car (entsel "\nSelect first - border reference polyline")) )
(setq obj1 (vlax-ename->vla-object ent1 ))
(setq obj2 (vlax-ename->vla-object (car (entsel "\nSelect second polyline")) ))
(setq ptu (getpoint "\nPick point that determins upper side of border polyline")) 
(setq ptd (getpoint "\nPick point that determins lower side of border polyline")) 
(setq fuzz (getdist "\nPick fuzz distance for checking boundaries - lower the number - better precision : "))

(command "offset" fuzz ent1 ptu "")
(setq obj1u (vlax-ename->vla-object (entlast)))
(setq ptlst (get_iplstpts obj1u obj2))
(setq ptlstn (length ptlst))
	(repeat (/ ptlstn 2)
	(setq pt1 (car ptlst))
	(setq pt2 (cadr ptlst))
	(setq param1 (vlax-curve-getParamAtPoint obj1u pt1))
	(setq param2 (vlax-curve-getParamAtPoint obj1u pt2))
	(setq param (/ (+ param1 param2) 2))
	(setq pt (vlax-curve-getPointAtParam obj1u param))
		(repeat 2
		(setq ptlst (cdr ptlst))
		)
	(setq ptlstupper (cons pt ptlstupper))
	)
(setq ptlstupper (reverse ptlstupper))
(entdel (entlast))

(command "offset" fuzz ent1 ptd "")
(setq obj1d (vlax-ename->vla-object (entlast)))
(setq ptlst (get_iplstpts obj1d obj2))
(setq ptlstn (length ptlst))
	(repeat (/ ptlstn 2)
	(setq pt1 (car ptlst))
	(setq pt2 (cadr ptlst))
	(setq param1 (vlax-curve-getParamAtPoint obj1d pt1))
	(setq param2 (vlax-curve-getParamAtPoint obj1d pt2))
	(setq param (/ (+ param1 param2) 2))
	(setq pt (vlax-curve-getPointAtParam obj1d param))
		(repeat 2
		(setq ptlst (cdr ptlst))
		)
	(setq ptlstlower (cons pt ptlstlower))
	)
(setq ptlstlower (reverse ptlstlower))
(entdel (entlast))

(setq ssup (ssadd))
	(foreach pt ptlstupper
	(command "boundary" pt "")
	(setq ent (entlast))
	(ssadd ent ssup)
	)

(setq k -1)
(setq auu 0.0000)
	(repeat (sslength ssup)
	(setq k (1+ k))
	(setq ent (ssname ssup k))
	(command "area" "o" ent "")
	(setq au (getvar "area"))
	(setq auu (+ au auu))
	)

(setq ssdwn (ssadd))
	(foreach pt ptlstlower
	(command "boundary" pt "")
	(setq ent (entlast))
	(ssadd ent ssdwn)
	)

(setq k -1)
(setq add 0.0000)
	(repeat (sslength ssdwn)
	(setq k (1+ k))
	(setq ent (ssname ssdwn k))
	(command "area" "o" ent "")
	(setq ad (getvar "area"))
	(setq add (+ ad add))
	)

(command "erase" ssup "")
(command "erase" ssdwn "")

(prompt "\nTotal Upper Areas are : ")(princ auu)(prompt "\nTotal Lower Areas are : ")(princ add)
(setvar "osmode" oscmd)

(princ)
)

M.R.

[alfacsys]

Thanks Marko
Great stuff
I will let you know the final product

[alfacsys]

Hi Marko

I have gone through the code. There is some problem. if the fuzz value is so lower or so higher some times it wont intersect the with the new offset entity, so that it omit the point for bpoly. we will not be able to identify whether it missed or not.
Sorry to bother you again and i really appreciate your effort you made. Is there any way to find the upper and lower vertex of two polylines from the same scenario.

[marko_ribar]

There is another problem you should consider...

If polyline for calculation don't touch reference - border polyline making "V" shape near border pline and fuzz is higher than lower vertex of "V" shape, offset pline will intersect pline for calculation 4 times on that segment, and therefore, you'll have 2 points for picking executing boundary poly command. So, instead of 1 boundary pline, you will have 2 overlapping plines, both considered in calculation of areas...

To avoid this, I suggest you make regions for all upper polylines, and use union command on all of them and then obtain area of that one region for upper areas (and the same this for lower areas).

P.S. Maybe the best way - not to make any changes to routine you already have is to pick fuzz so small that it won't intersect shape pline on 1 segment for more than 2 times - 1 point for making bpoly, and to be enough big number for taking its bpoly points in consideration while making them (for too small number you may receive message that point touches reference - border pline, bplolys won't be generated and calculated areas will be 0.0)...

M.R.

[marko_ribar]

Here is modified code that creates regions (more reliable results) :

;;=====================================
;;  return a list of intersect points  
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
  (if (not (vl-catch-all-error-p
             (setq iplist (vl-catch-all-apply
                            'vlax-safearray->list
                            (list
                              (vlax-variant-value
                                (vla-intersectwith obj1 obj2 acextendnone)
                              ))))))
    iplist
  )
)

(defun get_iplstpts (obj1 obj2 / iplst iplstn pt iplstpts)
(setq iplst (get_interpts obj1 obj2))
(setq iplstn (length iplst))
	(repeat (/ iplstn 3)
	(setq pt (list (car iplst) (cadr iplst) (caddr iplst)) )
		(repeat 3
		(setq iplst (cdr iplst))
		)
	(setq iplstpts (cons pt iplstpts))
	)
(setq iplstpts (reverse iplstpts))
)

(defun c:areabtw2pl ( / oscmd fuzz ent1 obj1 obj2 obj1u obj1d ptu ptd ptlst ptlstn pt1 param1 pt2 param2 

pt param ssup ssdwn ent k auu au add ad ptlstupper ptlstlower)
(vl-load-com)
(vl-cmdf "ucs" "w")
(setq oscmd (getvar "osmode"))
(setvar "luprec" 8)
(setvar "osmode" 0)
(setq ent1 (car (entsel "\nSelect first - border reference polyline")) )
(setq obj1 (vlax-ename->vla-object ent1 ))
(setq obj2 (vlax-ename->vla-object (car (entsel "\nSelect second polyline")) ))
(setq ptu (getpoint "\nPick point that determins upper side of border polyline")) 
(setq ptd (getpoint "\nPick point that determins lower side of border polyline")) 
(setq fuzz (getdist "\nPick fuzz distance for checking boundaries - lower the number - better precision : 

"))

(command "offset" fuzz ent1 ptu "")
(setq obj1u (vlax-ename->vla-object (entlast)))
(setq ptlst (get_iplstpts obj1u obj2))
(setq ptlstn (length ptlst))
	(repeat (/ ptlstn 2)
	(setq pt1 (car ptlst))
	(setq pt2 (cadr ptlst))
	(setq param1 (vlax-curve-getParamAtPoint obj1u pt1))
	(setq param2 (vlax-curve-getParamAtPoint obj1u pt2))
	(setq param (/ (+ param1 param2) 2))
	(setq pt (vlax-curve-getPointAtParam obj1u param))
		(repeat 2
		(setq ptlst (cdr ptlst))
		)
	(setq ptlstupper (cons pt ptlstupper))
	)
(setq ptlstupper (reverse ptlstupper))
(entdel (entlast))

(command "offset" fuzz ent1 ptd "")
(setq obj1d (vlax-ename->vla-object (entlast)))
(setq ptlst (get_iplstpts obj1d obj2))
(setq ptlstn (length ptlst))
	(repeat (/ ptlstn 2)
	(setq pt1 (car ptlst))
	(setq pt2 (cadr ptlst))
	(setq param1 (vlax-curve-getParamAtPoint obj1d pt1))
	(setq param2 (vlax-curve-getParamAtPoint obj1d pt2))
	(setq param (/ (+ param1 param2) 2))
	(setq pt (vlax-curve-getPointAtParam obj1d param))
		(repeat 2
		(setq ptlst (cdr ptlst))
		)
	(setq ptlstlower (cons pt ptlstlower))
	)
(setq ptlstlower (reverse ptlstlower))
(entdel (entlast))

(setq ssup (ssadd))
	(foreach pt ptlstupper
	(command "boundary" pt "")
	(setq ent (entlast))
	(ssadd ent ssup)
	)

(setq k -1)
	(repeat (sslength ssup)
	(setq k (1+ k))
	(setq ent (ssname ssup k))
	(command "region" ent "")
	(ssadd (entlast) ssup)
	)
(command "union" ssup "")
(command "area" "o" (entlast) "")
(setq auu (getvar "area"))
(ssadd (entlast) ssup)

(setq ssdwn (ssadd))
	(foreach pt ptlstlower
	(command "boundary" pt "")
	(setq ent (entlast))
	(ssadd ent ssdwn)
	)

(setq k -1)
	(repeat (sslength ssdwn)
	(setq k (1+ k))
	(setq ent (ssname ssdwn k))
	(command "region" ent "")
	(ssadd (entlast) ssdwn)
	)
(command "union" ssdwn "")
(command "area" "o" (entlast) "")
(setq add (getvar "area"))
(ssadd (entlast) ssdwn)

(command "erase" ssup "")
(command "erase" ssdwn "")

(prompt "\nTotal Upper Areas are : ")(princ auu)(prompt "\nTotal Lower Areas are : ")(princ add)
(setvar "osmode" oscmd)

(princ)
)

M.R.

[alfacsys]

Thanks Mrko

Sorry still in some drawing i get unexpected Total area and in some case very accurate. i am playing with the code. i get you my findings if i could (it seems I couldnt)
Once again thank you for your quick response and effort

Aleem

[GHarvey]

I found this problem rather interesting, so I put some time into working through it. What I came up with seems to work with the sample drawing you provided, though I can't say much beyond that. It isn't very polished, but if you are still looking for a solution perhaps this will help.

;; C:TBOT PROMPTS FOR THE SELECTION OF TWO LIGHTWEIGHT POLYLINES REFERRED TO AS "GROUND" AND
;; "FORMATION". IT THEN RETURNS THE TOTAL AREAS FORMED ABOVE AND BELOW "GROUND" BETWEEN IT
;; AND "FORMATION".
(defun c:tbot ( / ABOVE ACTIVEDOC BELOW BLOCKS FORMATION FORMATION-LIMS GROUND GROUND-LIMS
               INT-PTS PT-LST PTMID PTMID-F PTMID-G REG-X REMS WORK-BLK)
  (vl-load-com)
  (setq activedoc (vla-get-activedocument (vlax-get-acad-object))
        blocks (vla-get-blocks activedoc)
        ground (vlax-ename->vla-object (car (entsel "\nPick the ground ")))
        formation (vlax-ename->vla-object (car (entsel "\nPick the formation ")))
        int-pts (vlax-safearray->list
                  (vlax-variant-value
                    (vla-intersectwith ground formation acExtendNone)
                    ); vlax-variant-value
                  ); vlax-safearray->list
        ); setq
  (defun subpln (a b pln / LST N ST-ND)
    (setq st-nd (vl-sort
                  (list
                    (vlax-curve-getParamAtPoint pln a)
                    (vlax-curve-getParamAtPoint pln b)
                    ); list
                  '<
                  ); vl-sort
          n (1+ (fix (car st-nd)))
          ); setq
    (while (< n (cadr st-nd))
      (setq lst (append lst
                        (reverse
                          (cdr
                            (reverse
                              (vlax-curve-getPointAtParam pln n)
                              ); reverse
                            ); cdr
                          ); reverse
                        ); append
            n (1+ n)
            ); setq
      ); while
    (setq lst (append (reverse
                        (cdr
                          (reverse
                            (vlax-curve-getPointAtParam pln (car st-nd))
                            ); reverse
                          ); cdr
                        ); reverse
                      lst
                      (reverse
                        (cdr
                          (reverse
                            (vlax-curve-getPointAtParam pln (cadr st-nd))
                            ); reverse
                          ); cdr
                        ); reverse
                      ); append
          ); setq
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray
          vlax-vbdouble
          (cons 0 (1- (length lst)))
          ); vlax-make-safearray
        lst
        ); vlax-safearray-fill
      (+ vlax-vbarray vlax-vbdouble)
      ); vlax-make-variant
    ); defun
  (while
    (setq rems (cdddr int-pts))
    (setq pt-lst (append pt-lst (list (list (car int-pts) (cadr int-pts))))
          int-pts rems
          ); setq
    ); while
  (setq ground-lims (vl-sort
                      (list
                        (vlax-curve-getParamAtPoint ground (car pt-lst))
                        (vlax-curve-getParamAtPoint ground (last pt-lst))
                        ); list
                      '<
                      ); vl-sort
        formation-lims (vl-sort
                         (list
                           (vlax-curve-getParamAtPoint formation (car pt-lst))
                           (vlax-curve-getParamAtPoint formation (last pt-lst))
                           ); list
                         '<
                         ); vl-sort
        ); setq
  (cond ((>= (vlax-curve-getStartParam ground) (car ground-lims)) nil)
        ((not (vlax-curve-getParamAtPoint formation (vlax-curve-getStartPoint ground))) nil)
        (t (setq pt-lst (append (list (reverse
                                        (cdr
                                          (reverse
                                            (vlax-curve-getStartPoint ground)
                                            ); reverse
                                          ); cdr
                                        ); reverse
                                      ); list
                                pt-lst
                                ); append
                 ); setq
         ); default
        ); cond
  (cond ((>= (vlax-curve-getStartParam formation) (car formation-lims)) nil)
        ((not (vlax-curve-getParamAtPoint ground (vlax-curve-getStartPoint formation))) nil)
        (t (setq pt-lst (append (list (reverse
                                        (cdr
                                          (reverse
                                            (vlax-curve-getStartPoint formation)
                                            ); reverse
                                          ); cdr
                                        ); reverse
                                      ); list
                                pt-lst
                                ); append
                 ); setq
         ); default
        ); cond
  (cond ((<= (vlax-curve-getendparam ground) (car ground-lims)) nil)
        ((not (vlax-curve-getParamAtPoint formation (vlax-curve-getEndPoint ground))) nil)
        (t (setq pt-lst (append pt-lst
                                (list
                                  (reverse
                                    (cdr
                                      (reverse
                                        (vlax-curve-getEndPoint ground)
                                        ); reverse
                                      ); cdr
                                    ); reverse
                                  ); list
                                ); append
                 ); setq
         ); default
        ); cond
  (cond ((<= (vlax-curve-getendparam formation) (car formation-lims)) nil)
        ((not (vlax-curve-getParamAtPoint ground (vlax-curve-getEndPoint formation))) nil)
        (t (setq pt-lst (append pt-lst
                                (list
                                  (reverse
                                    (cdr
                                      (reverse
                                        (vlax-curve-getEndPoint formation)
                                        ); reverse
                                      ); cdr
                                    ); reverse
                                  ); list
                                ); append
                 ); setq
         ); default
        ); cond
  (if (> (length pt-lst) 1)
    (progn
      (setq work-blk (vla-add blocks (vlax-3d-point '(0.0 0.0 0.0)) "*u"))
      (while
        (> (length pt-lst) 1)
        (setq ptmid (mapcar '/ (mapcar '+ (car pt-lst) (cadr pt-lst)) (list 2.0 2.0))
              ptmid-g (vlax-curve-getClosestPointToProjection ground ptmid (list 0.0 1.0 0.0))
              ptmid-f (vlax-curve-getClosestPointToProjection formation ptmid (list 0.0 1.0 0.0))
              reg-x (vl-catch-all-apply
                      'vla-addregion
                      (list
                        work-blk
                        (vlax-safearray-fill
                          (vlax-make-safearray
                            vlax-vbobject
                            '(0 . 1)
                            ); vlax-make-safearray
                          (list
                            (vla-addlightweightpolyline
                              work-blk
                              (subpln (car pt-lst) (cadr pt-lst) ground)
                              ); vla-addlightweightpolyline
                            (vla-addlightweightpolyline
                              work-blk
                              (subpln (car pt-lst) (cadr pt-lst) formation)
                              ); vla-addlightweightpolyline
                            ); list
                          ); vla-safearray-fill
                        ); list
                      ); vl-catch-all-apply
              pt-lst (cdr pt-lst)
              ); setq
        (cond ((vl-catch-all-error-p reg-x) nil)
              ((null reg-x) nil)
              ((vl-catch-all-error-p
                 (setq reg-x (vl-catch-all-apply
                               'vlax-safearray->list
                               (list
                                 (vlax-variant-value reg-x)
                                 ); list
                               ); vl-catch-all-apply
                       ); setq
                 ); vl-catch-all-error-p
               nil
               ); no region(s) returned
              ((> (cadr ptmid-f) (cadr ptmid-g))
               (setq above (append above (list (vla-get-area (car reg-x)))))
               ); area is above ground
              (t
               (setq below (append below (list (vla-get-area (car reg-x)))))
               ); area is below ground
              ); cond
        ); while
      (setq t-ar-above (apply '+ above)
            t-ar-below (apply '+ below)
            ); setq
      (vl-catch-all-apply 'vla-delete (list work-blk))
      ); progn
    (progn
      (setq t-ar-above 0
            t-ar-below 0
            ); setq
      ); progn
    ); if
  (progn
    (alert (strcat "\nArea Above = " (rtos t-ar-above) "    Area Below = " (rtos t-ar-below)))
    (princ)
    )
  ); defun

Note that it leaves behind two global variables, t-ar-above and t-ar-below, which store the net areas above and below the reference line, respectively.