Cutting Area

March 21, 2009

i need someone who could make this cad lisp for cutting area from a big parcel of land..i am seek and tired manually computing for a portion of land.

Here is my sample..

March 21, 2009

What is the thought process;

-given a parcel of land, can be any irregular shape

-need to cut off a portion, based on a known target area

-the cut line will always be parallel to one side that user selects?

Q?

-will the parcel always be a closed polyline, or is it made up of lines.

March 21, 2009

My thinking in Pseudo code...

Select outer boundary, select parallel line.

Then, somehow, form a closed polyline from the selected line and where it intersects the main polyline... could be troublesome finding which side to get area from... may need another selection from user.

Finally, use the AREA command to find the area..

March 21, 2009

What is the thought process;

-given a parcel of land, can be any irregular shape

-need to cut off a portion, based on a known target area

-the cut line will always be parallel to one side that user selects?

Q?

-will the parcel always be a closed polyline, or is it made up of lines.

yes the parcel is polyline...

here is another sample of land..

with this one lots of points or corners so it takes time for me compute..

hope someday help this probs.

thank you.

oliver

March 21, 2009

Can you not just break the outer pline at the intersection of the parallel line, and make it into a closed pline and just use the area command?

Or is that what you have already been doing?

March 22, 2009

Can you not just break the outer pline at the intersection of the parallel line, and make it into a closed pline and just use the area command?

Or is that what you have already been doing?

yap..i made it manually before by offset from the reference line or baseline and adjusting 20x..

and you said make it try the area command..i'm doing that for whole time but nothing gonna make it..it just only ADD and SUBTRACT..

oliver

March 22, 2009

Oh..gr8t..i found a routine lisp.

;;;DIVAREA.LSP  Land division utility
;;;  Suppose that you have to split a big part into 2, 3, 4 (or even 5.014!)
;;;  or you want to cut a part of 2345 m2 out of the big one.
;;;
;;;  All you need is a CLOSED LWPOLYLINE enclosing the big part.
;;;
;;;  Load the utility, after placing it into an appropriate folder,
;;;  let's say \Program Files\Acad2000\Support, invoke "APPLOAD" command
;;;  or invoke (LOAD"DIVAREA") and run it by typing DIVAREA.
;;;
;;;  Answer the few questions you will be asked and REMEMBER:
;;;
;;;  When you are prompted to indicate the two points of
;;;  the approximate division line, please bear in mind that
;;;
;;;     1. This DIVISION LINE will be rotated (or be offseted) and
;;;  neither of its endpoints should reside outside of the boundary,
;;;  (although it should have been easy to overcome this bug),
;;;  so pick points as FAR OUT from the boundary as possible,
;;;  not exceeding, of course, your current visibe area.
;;;  As for the FIXED POINT, in case you prefer "F"
;;;  rather than "C" as an answer in the previous question, it has to
;;;  reside on the lwpoly or outside of it, never inside.
;;;
;;;     2. When indicating point into the part which will obtain the desired
;;;  area, you have to indicate INTO it and AS FAR from division line as
;;;  possible, so this point will not be outside of the desired part
;;;  while the division line is moving into it.
;;;
;;;     3. Finally, you have to indicate exactly by the same way,
;;;  FAR FROM DIVISION line and INTO the remaining piece.

;;;  If you prefer more precision you can decrease local vars step2
;;;  and step1 accordingly.
;;;
;;;******************UTILITY STARTS HERE*******************************
(defun prerr (s)
(if (/= s "Function cancelled")
    (princ (strcat "\nError: " s))
);endif
(setq *error* olderr)
(princ)
);close defun
(Defun C:DIVAREA(/ osm strpf strdc ex arxset arx arxon k scl ok
                  d p1 p2 pts ptb deln ar par tem
                  stp stp1 stp2               
               )
(setq olderr *error*
      *error* prerr)
(setq osm(getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq ex 0
      stp  0.01
      stp1 0.005
      stp2 0.0005
)
(setq arxset (entsel "\nSelect closed LWPOLY to divide: ")
      arx    (entget(car arxset))
      arxon  (cdr (assoc -1 arx))
)
(if (not(and(equal (cdr(assoc 0 arx)) "LWPOLYLINE") (= (cdr(assoc 70 arx)) 1)))
    (progn
          (princ "\nSORRY, ONLY CLOSED LWPOLYLINES ALLOWED...")
          (setq ex 1)
    )
)
(if (= ex 0)
    (progn
      (command "_undo" "m") ;if something goes bad, you may return here
      (command "_layer" "m" "Area_Division" "")
      (command "_area" "e" arxon)
      (setq ar(getvar "area"))
      (initget "Divide Cut")
      (setq strdc(getkword "\nDIVIDE by number or CUT a part ? (D/C) :"))
      (if (= strdc "Divide")
          (progn
                (setq k  (getreal "\nEnter number to divide the whole part by : "))
                (setq tem(/ ar k))
          )
      )
      (if (= strdc "Cut")
          (setq tem (getreal "\nEnter area to cut from the whole part (m2) : "))
      )
      (initget "Parallel Fixed")
      (setq strpf(getkword "\nPARALLEL to a direction or FIXED side? (P/F) :"))
      (if (= strpf "Fixed")
          (fixpt)
      )
      (if (= strpf "Parallel")
          (parpt)
      )
      (ready)
    )
    (ready)
)
)
;******************************************************************************
(defun fixpt ()
(setvar "osmode" osm)
(setq scl    0.05
      p1     (getpoint "\nPick fixed point of the division line : ")
      p2     (getpoint "\nPick second point of division line: ")
)
(setvar "osmode" 0)
(command "_line" p1 p2 "")
(setq deln (entlast))
(setq pts (getpoint "\nPick any point into FIRST piece, FAR from division line: "))
(setq ptb (getpoint "\nPick any point into the REST of the piece, FAR from division line: "))
(setvar "blipmode" 0)
(princ "\nPlease wait...")
(command "_boundary" pts "")
(command "_area" "e" "l")
(setq par(getvar "area"))
(setq ok -1)
(if (< par tem)
 (progn
       (while (< par tem)
        (entdel (entlast))
        (if (< (- tem par) 50)(setq scl stp))
        (if (< (- tem par) 10)(setq scl stp2))
        (command "_rotate" deln "" p1 (* scl ok))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (if (< (getvar "area") par)
            (setq ok(* ok -1))
        )
        (setq par(getvar "area"))
       );endwhile
       (entdel deln)
)
 (progn
       (while (> par tem)
        (entdel (entlast))
        (if (< (- par tem) 50)(setq scl stp))
        (if (< (- par tem) 10)(setq scl stp2))
        (command "_rotate" deln "" p1 (* scl ok))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (if (> (getvar "area") par)
            (setq ok(* ok -1))
        )
        (setq par(getvar "area"))
       );endwhile
       (entdel deln)
)
)
(command "_change" "l" "" "p" "c" "green" "")
(command "_boundary" ptb "")
(command "_change" "l" "" "p" "c" "red" "")
(ready)
)
;******************************************************************************
(defun parpt ()
(setvar "osmode" osm)
(setq scl    0.25
      p1     (getpoint "\nPick one point of division line (far from lwpoly) : ")
      p2     (getpoint "\nPick other point of division line (far from lwpoly) : ")
)
(setvar "osmode" 0)
(command "_line" p1 p2 "")
(setq deln(entlast))
(setq pts (getpoint "\nPick any point into FIRST piece, FAR from division line: "))
(setq ptb (getpoint "\nPick any point into the REST of the piece, FAR from division line: "))
(setvar "blipmode" 0)
(princ "\nPlease wait...")
(command "_boundary" pts "")
(command "_area" "e" "l")
(setq par(getvar "area"))
(if (< par tem)
 (progn
       (while (< par tem)
        (entdel (entlast))
        (if (< (- tem par) 50)(setq scl stp1))
        (if (< (- tem par) 10)(setq scl stp2))
        (command "_offset" scl deln ptb "")
        (entdel deln)
        (setq deln(entlast))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (setq par(getvar "area"))
       )
       (entdel deln)
 )
 (progn
       (while (> par tem)
        (entdel (entlast))
        (if (< (- par tem) 50)(setq scl stp1))
        (if (< (- par tem) 10)(setq scl stp2))
        (command "_offset" scl deln pts "")
        (entdel deln)
        (setq deln(entlast))
        (command "_boundary" pts "")
        (command "_area" "e" "l")
        (setq par(getvar "area"))
       )
       (entdel deln)
 )
)
(command "_change" "l" "" "p" "c" "green" "")
(command "_boundary" ptb "")
(command "_change" "l" "" "p" "c" "red" "")
)
;******************************************************************************
(defun ready ()
 (princ scl)
 (princ "\nActual : ")
 (princ par)
 (princ "\nMust be: ")
 (princ tem)
(setq *error* olderr)
(setvar "osmode" osm)
(setvar "cmdecho" 1)
(setvar "blipmode" 1)
(princ "\nThanks...")
(princ)
);close defun

cheers

oliver

March 22, 2009

also you may try:

http://cadtips.cadalyst.com/2d-editing/subdivide-lot-desired-areas-equal-or-unequal

March 23, 2009

Maybe this?

;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;    (contact ~ Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================


(defun c:ADiv  (/ *error* vlst ovar spc cEnt vpt cCur
         cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly)
 
 (vl-load-com)

 (defun *error*  (msg)
   (grtext) (redraw)
   (if    ovar (mapcar 'setvar vlst ovar))
   (if    (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\n<!> Error: " (strcase msg) " <!>")))
   (princ))

 (setq    vlst '("CMDECHO" "OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))

 (setq    spc (vla-get-ModelSpace
         (vla-get-ActiveDocument
       (vlax-get-Acad-Object))))

 (if (and (setq cEnt (entsel "\nSelect Edge for Segregation: "))
      (eq "LWPOLYLINE" (cdadr (entget (car cEnt)))))        
   (progn
     (setq vpt (osnap (cadr cEnt) "_nea")
       cCur (vlax-ename->vla-object (car cEnt))
       cAng (angle    '(0 0 0) (vlax-curve-getFirstDeriv cCur
                  (vlax-curve-getParamAtPoint cCur vpt))))
     (setq clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt))))))
     (grtext -1 "Select Area Segregation...")
     (while (= 5 (car (setq grlist (grread t 1))))
   (redraw)
   (if (= 'list (type (setq arpt (cadr grlist))))
     (progn
       (setq spt (vlax-curve-getClosestPointto cCur arpt)
         pt1 (polar spt cAng (/ clen 3.0))
         pt2 (polar spt cAng (/ clen -3.0)))
       (grdraw pt1 pt2 3))))
     (setq iLin (vla-Addline spc (vlax-3D-point spt)
          (vlax-3D-point (polar spt cAng clen)))
       iArr (vlax-variant-value
          (vla-IntersectWith iLin cCur acExtendThisEntity)))
     (if (> (vlax-safearray-get-u-bound iArr 1) 0)
   (progn
     (setq iLst (vlax-safearray->list iArr))
     (while (not (zerop (length iLst)))
       (setq ptLst    (cons (list (car iLst) (cadr iLst) (caddr iLst)) ptLst)
         iLst    (cdddr iLst)))
     (and (vla-delete iLin) (setq iLin nil))
     (if (> (length ptlst) 1)
       (progn
         (setq plst  (vl-sort (list (vlax-curve-getParamAtPoint cCur (car ptLst))
               (vlax-curve-getParamAtPoint cCur (cadr ptLst))) '<)
           stpar (1+ (fix (car plst))))
         (while (< stpar (cadr plst))
       (setq plst (append plst (list stpar))
             stpar (1+ stpar)))
         (setq plst (vl-sort plst '<)
           vpts (mapcar '(lambda (p) (vlax-curve-getPointatParam cCur p)) plst))
         (command "_pline") (foreach x vpts (command x)) (command "_C")
         (vla-put-color (setq aPly (vlax-ename->vla-object (entlast))) acRed)
         (princ (strcat "\n<<<  Area of Enclosed Region: " (rtos (vla-get-Area aPly)) " >>>")))
       (princ "\n<!> Selected Segregation not Closed <!>")))
   (princ "\n<!> Area Not Segregated Properly <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (grtext) (redraw)
 (princ))

(princ "\n** AreaDiv.lsp Successfully Loaded - type \"ADiv\" to invoke **") (princ)

March 23, 2009

Maybe this?

;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;    (contact ~ Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================


(defun c:ADiv  (/ *error* vlst ovar spc cEnt vpt cCur
         cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly)
 
 (vl-load-com)

 (defun *error*  (msg)
   (grtext) (redraw)
   (if    ovar (mapcar 'setvar vlst ovar))
   (if    (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\n<!> Error: " (strcase msg) " <!>")))
   (princ))

 (setq    vlst '("CMDECHO" "OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))

 (setq    spc (vla-get-ModelSpace
         (vla-get-ActiveDocument
       (vlax-get-Acad-Object))))

 (if (and (setq cEnt (entsel "\nSelect Edge for Segregation: "))
      (eq "LWPOLYLINE" (cdadr (entget (car cEnt)))))        
   (progn
     (setq vpt (osnap (cadr cEnt) "_nea")
       cCur (vlax-ename->vla-object (car cEnt))
       cAng (angle    '(0 0 0) (vlax-curve-getFirstDeriv cCur
                  (vlax-curve-getParamAtPoint cCur vpt))))
     (setq clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt))))))
     (grtext -1 "Select Area Segregation...")
     (while (= 5 (car (setq grlist (grread t 1))))
   (redraw)
   (if (= 'list (type (setq arpt (cadr grlist))))
     (progn
       (setq spt (vlax-curve-getClosestPointto cCur arpt)
         pt1 (polar spt cAng (/ clen 3.0))
         pt2 (polar spt cAng (/ clen -3.0)))
       (grdraw pt1 pt2 3))))
     (setq iLin (vla-Addline spc (vlax-3D-point spt)
          (vlax-3D-point (polar spt cAng clen)))
       iArr (vlax-variant-value
          (vla-IntersectWith iLin cCur acExtendThisEntity)))
     (if (> (vlax-safearray-get-u-bound iArr 1) 0)
   (progn
     (setq iLst (vlax-safearray->list iArr))
     (while (not (zerop (length iLst)))
       (setq ptLst    (cons (list (car iLst) (cadr iLst) (caddr iLst)) ptLst)
         iLst    (cdddr iLst)))
     (and (vla-delete iLin) (setq iLin nil))
     (if (> (length ptlst) 1)
       (progn
         (setq plst  (vl-sort (list (vlax-curve-getParamAtPoint cCur (car ptLst))
               (vlax-curve-getParamAtPoint cCur (cadr ptLst))) '<)
           stpar (1+ (fix (car plst))))
         (while (< stpar (cadr plst))
       (setq plst (append plst (list stpar))
             stpar (1+ stpar)))
         (setq plst (vl-sort plst '<)
           vpts (mapcar '(lambda (p) (vlax-curve-getPointatParam cCur p)) plst))
         (command "_pline") (foreach x vpts (command x)) (command "_C")
         (vla-put-color (setq aPly (vlax-ename->vla-object (entlast))) acRed)
         (princ (strcat "\n<<<  Area of Enclosed Region: " (rtos (vla-get-Area aPly)) " >>>")))
       (princ "\n<!> Selected Segregation not Closed <!>")))
   (princ "\n<!> Area Not Segregated Properly <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (grtext) (redraw)
 (princ))

(princ "\n** AreaDiv.lsp Successfully Loaded - type \"ADiv\" to invoke **") (princ)

thanks for the effort..i think u are miss something..i didnt see any target area required

oliver

March 23, 2009

thanks for the effort..i think u are miss something..i didnt see any target area required

oliver

The area is retrieved afterwards... - you use it to partition your main region, then the area is displayed.

March 23, 2009

See attached video for details...

AreaDiv.zip

March 23, 2009

See attached video for details...

ok...what we want now is a target area..f the area is 1000 sq.m..just required only 350 sq.m..as shown on the video only, can put anywhere u want..

March 23, 2009

Ok, this is better:

;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;  (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================


(defun c:ADiv  (/ *error* vlst ovar doc spc cEnt ParamLst vpt
         cCur cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly int1 int2
         2vpts bPly ObjArr Regs aReg bReg tCenLst tCen
         tht Area_text)
 
 (vl-load-com)

 (defun *error*  (msg)
   (grtext) (redraw)
   (if    ovar (mapcar 'setvar vlst ovar))
   (if    (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\n<!> Error: " (strcase msg) " <!>")))
   (princ))

 (setq    vlst '("CMDECHO" "OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))

 (setq    doc (vla-get-ActiveDocument
         (vlax-get-Acad-Object))
   
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
       (vla-get-modelspace doc)
       (vla-get-paperspace doc))
         (vla-get-modelspace doc)))  

 (if (and (setq cEnt (entsel "\nSelect Edge for Segregation: "))
      (eq "LWPOLYLINE" (cdadr (entget (car cEnt)))))        
   (progn      
     (setq vpt (osnap (cadr cEnt) "_nea")
       cCur (vlax-ename->vla-object (car cEnt))
       cAng (angle    '(0 0 0) (vlax-curve-getFirstDeriv cCur
                  (vlax-curve-getParamAtPoint cCur vpt))))
     (setq clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt))))))
     (setq ParamLst (mapcar '(lambda (cVert) (vlax-curve-getParamAtPoint cCur cVert))
                (mapcar 'cdr (vl-remove-if-not
                       '(lambda (x) (= 10 (car x)))
                       (entget (car cEnt))))))
     
     (grtext -1 "Select Area Segregation...")
     (while (= 5 (car (setq grlist (grread t 1))))
   (redraw)
   (if (= 'list (type (setq arpt (cadr grlist))))
     (progn
       (setq spt (vlax-curve-getClosestPointto cCur arpt)
         pt1 (polar spt cAng (/ clen 3.0))
         pt2 (polar spt cAng (/ clen -3.0)))
       (grdraw pt1 pt2 3))))
     
     (setq iLin (vla-Addline spc (vlax-3D-point spt)
          (vlax-3D-point (polar spt cAng clen)))
       iArr (vlax-variant-value
          (vla-IntersectWith iLin cCur acExtendThisEntity)))
     (if (> (vlax-safearray-get-u-bound iArr 1) 0)
   (progn
     (setq iLst (vlax-safearray->list iArr))
     (while (not (zerop (length iLst)))
       (setq ptLst    (cons (list (car iLst) (cadr iLst) (caddr iLst)) ptLst)
         iLst    (cdddr iLst)))
     (and (vla-delete iLin) (setq iLin nil))
     
     (if (> (length ptlst) 1)
       (progn
         (setq plst  (vl-sort (list (setq int1 (vlax-curve-getParamAtPoint cCur (car ptLst)))
               (setq int2 (vlax-curve-getParamAtPoint cCur (cadr ptLst)))) '<)
           stpar (1+ (fix (car plst))))
         (while (< stpar (cadr plst))
       (setq plst (append plst (list stpar))
             stpar (1+ stpar)))
         (setq plst (vl-sort plst '<)
           vpts (apply 'append
               (mapcar '(lambda (x) (list (car x) (cadr x)))
                   (mapcar '(lambda (p)
                          (vlax-curve-getPointatParam cCur p)) plst))))
         (setq vpts (vlax-make-variant
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length vpts)))) vpts)))
         (setq aPly (vla-AddLightWeightPolyline spc vpts))
         (vla-put-closed aPly :vlax-true)
         (setq ParamLst (vl-sort
                  (append
                (vl-remove-if
                  '(lambda (param) (member param plst)) ParamLst)
                (list int1 int2)) '<)
           2vpts (apply 'append
                (mapcar '(lambda (x) (list (car x) (cadr x)))
                 (mapcar '(lambda (p)
                        (vlax-curve-getPointatParam cCur p)) ParamLst))))
         (setq 2vpts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length 2vpts)))) 2vpts)))
         (setq bPly (vla-AddLightWeightPolyline spc 2vpts))
         (vla-put-Closed bPly :vlax-true)          

         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray vlax-vbobject '(0 . 1)) (list aPly bPly))
           Regs (vlax-safearray->list
              (vlax-variant-value
                (vla-AddRegion spc ObjArr)))
           aReg (car Regs) bReg (cadr Regs))
         (mapcar 'vla-delete (list aPly bPly))
         (vla-put-color aReg acRed)
         (vla-put-color bReg acGreen)
         (setq tCenLst (mapcar '(lambda (c) (vlax-safearray->list
                       (vlax-variant-value
                         (vla-get-Centroid c)))) (list aReg bReg)))
         (setq tCen (mapcar 'vlax-3d-point
                (mapcar 'append tCenLst (list (list 0.0) (list 0.0))))
           tht (getvar "TEXTSIZE")
           Area_text (mapcar 'vla-AddText (list spc spc)
                     (mapcar '(lambda (str) (strcat "Area: " (rtos str)))
                         (mapcar 'vla-get-Area (list aReg bReg)))
                     tCen (list tht tht)))
         (mapcar 'vla-put-color Area_text (list acRed acGreen))
         
         (princ (strcat "\n<<<  Red Area: " (rtos (vla-get-Area aReg))
                ", Green Area: " (rtos (vla-get-Area bReg)) " >>>")))
       
       (princ "\n<!> Selected Segregation not Closed <!>")))
   (princ "\n<!> Area Not Segregated Properly <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (grtext) (redraw)
 (princ))

(princ "\n** AreaDiv.lsp Successfully Loaded - type \"ADiv\" to invoke **") (princ)

March 23, 2009

its good..but does not my point my freind...

i have a routine here..try to update same as what you need..

(defun ang_between (p10 p11 p20 p21 / px p1 p2 l_pt l_d p ang)
   (setq px (inters p10 p11 p20 p21 nil))
   (cond
       (px
           (if (> (distance px p10) (distance px p11)) (setq p1 p10) (setq p1 p11))
           (if (> (distance px p20) (distance px p21)) (setq p2 p20) (setq p2 p21))
           (setq
               l_pt (list px p1 p2)
               l_d (mapcar 'distance l_pt (append (cdr l_pt) (list (car l_pt))))
               p (/ (apply '+ l_d) 2.0)
               ang (* (atan (sqrt (/ (* (- p (car l_d)) (- p (caddr l_d))) (* p (- p (cadr l_d)))))) 2.0)
           )
       )
       (T
           nil
       )
   )
)
(defun c:cu ( / pt1 pt2 pt3 pt4 S1 ang1 ang2 x1 x2 ptx1 ptx2)
 (setq pt1 (getpoint "\nFirst point of baseline: "))
 (setq pt2 (getpoint pt1 "\nSecond point of baseline: "))
 (setq pt3 (getpoint pt1 "\nPoint of first adjacent side: "))
 (setq pt4 (getpoint pt2 "\nPoint of second adjacent side: "))
 (setq S1 (getreal "\nWanted area: "))
 (setq ang1 (ang_between pt1 pt2 pt1 pt3))
 (setq ang2 (ang_between pt2 pt1 pt2 pt4))
 (setq ang1 (- pi ang1) ang2 (- pi ang2))
 (setq x1
   (*
     (/
       (* (distance pt1 pt2) (sin ang1))
       (sin (+ ang1 ang2))
     )
     (1-
       (+ ;or can be "-"
         (sqrt
           (1+
             (/
               (* 2.0 S1 (sin (+ ang1 ang2)))
               (* (distance pt1 pt2) (distance pt1 pt2) (sin ang1) (sin ang2))
             )
           )
         )
       )
     )
   )
 )
 (setq x2 (/ (* x1 (sin ang2)) (sin ang1)))
 (setq ptx1 (polar pt1 (angle pt1 pt3) x2))
 (setq ptx2 (polar pt2 (angle pt2 pt4) x1))
 (command "_.line" "_none" ptx1 "_none" ptx2 "")
)

cheers

oliver

March 24, 2009

its good..but does not my point my freind...

i have a routine here..try to update same as what you need..

(defun ang_between (p10 p11 p20 p21 / px p1 p2 l_pt l_d p ang)
   (setq px (inters p10 p11 p20 p21 nil))
   (cond
       (px
           (if (> (distance px p10) (distance px p11)) (setq p1 p10) (setq p1 p11))
           (if (> (distance px p20) (distance px p21)) (setq p2 p20) (setq p2 p21))
           (setq
               l_pt (list px p1 p2)
               l_d (mapcar 'distance l_pt (append (cdr l_pt) (list (car l_pt))))
               p (/ (apply '+ l_d) 2.0)
               ang (* (atan (sqrt (/ (* (- p (car l_d)) (- p (caddr l_d))) (* p (- p (cadr l_d)))))) 2.0)
           )
       )
       (T
           nil
       )
   )
)
(defun c:cu ( / pt1 pt2 pt3 pt4 S1 ang1 ang2 x1 x2 ptx1 ptx2)
 (setq pt1 (getpoint "\nFirst point of baseline: "))
 (setq pt2 (getpoint pt1 "\nSecond point of baseline: "))
 (setq pt3 (getpoint pt1 "\nPoint of first adjacent side: "))
 (setq pt4 (getpoint pt2 "\nPoint of second adjacent side: "))
 (setq S1 (getreal "\nWanted area: "))
 (setq ang1 (ang_between pt1 pt2 pt1 pt3))
 (setq ang2 (ang_between pt2 pt1 pt2 pt4))
 (setq ang1 (- pi ang1) ang2 (- pi ang2))
 (setq x1
   (*
     (/
       (* (distance pt1 pt2) (sin ang1))
       (sin (+ ang1 ang2))
     )
     (1-
       (+ ;or can be "-"
         (sqrt
           (1+
             (/
               (* 2.0 S1 (sin (+ ang1 ang2)))
               (* (distance pt1 pt2) (distance pt1 pt2) (sin ang1) (sin ang2))
             )
           )
         )
       )
     )
   )
 )
 (setq x2 (/ (* x1 (sin ang2)) (sin ang1)))
 (setq ptx1 (polar pt1 (angle pt1 pt3) x2))
 (setq ptx2 (polar pt2 (angle pt2 pt4) x1))
 (command "_.line" "_none" ptx1 "_none" ptx2 "")
)

cheers

oliver

What are you talking about?

Have I not satsified the original post?

March 24, 2009

Lee-

Your routine didn't work for me so I'm not sure...

but from previous posts you seemed to have missed that user is to enter a target area - for example the final segregated area needs to be "1000 sf" - and the routine figures out where to place the dividing line to create this subarea with exactly this area.

Would proably take some iteration.

March 24, 2009

The soloution to the problem is part of the parcels option in Civil 3d or also other civil software such as Civilcad.

You have multiple options to create lots, parallel line, swing bearing, frontage distance etc these aks for area required and as above iterate to find soloution. there very fast to use.

So a lisp program would need to iterate the line answer down to a tolerance. If metric say 1mm.

March 24, 2009

oh, must've missed that post/could'nt understand it.

Just wanted to upgrade my other LISP though anyway

;;;=======================================================
;;;=======================================================
;;;
;;;  FUNCTION: Area Division (AreaDiv.lsp)
;;;  Calculates the area of a partitioned region and
;;;  displays the result as text at the centroid of the
;;;  partitioned area.
;;;
;;;  AUTHOR
;;;  Copyright © 2009 Lee McDonnell
;;;  (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION
;;;  1.0  ~  23.03.2009
;;;
;;;=======================================================
;;;=======================================================


(defun c:ADiv  (/ *error* vlst ovar doc spc cEnt ParamLst vpt
         cCur cAng clen grlist arpt spt pt1 pt2 iLin
         iArr iLst ptLst plst stpar vpts aPly int1 int2
         2vpts bPly ObjArr Regs aReg bReg tCenLst tCen
         tht Area_text movp CurDel Cenpt Thtov VecCol)

 ; ===== Adjustments ======

 (setq CurDel T)   ;;  Delete Original Region

 (setq Cenpt nil)  ;;  Points at Region Centroids

 (setq Thtov 0.0)  ;;  Text Height Override

 (setq VecCol 3)   ;;  Partition Tool Colour (0-255)

 ; ========================
 
 (vl-load-com)

 (defun *error*  (msg)
   (grtext) (redraw)
   (if    ovar (mapcar 'setvar vlst ovar))
   (if    (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\n<!> Error: " (strcase msg) " <!>")))
   (princ))

 (setq    vlst '("CMDECHO" "OSMODE" "PDMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 0))

 (setq    doc (vla-get-ActiveDocument
         (vlax-get-Acad-Object))
   
   spc (if (zerop (vla-get-activespace doc))
         (if (= (vla-get-mspace doc) :vlax-true)
       (vla-get-modelspace doc)
       (vla-get-paperspace doc))
         (vla-get-modelspace doc)))  

 (if (and (setq cEnt (entsel "\nSelect Edge for Segregation: "))
      (eq "LWPOLYLINE" (cdadr (entget (car cEnt)))))        
   (progn      
     (setq vpt (osnap (cadr cEnt) "_nea")
       cCur (vlax-ename->vla-object (car cEnt))
       cAng (angle    '(0 0 0) (vlax-curve-getFirstDeriv cCur
                  (vlax-curve-getParamAtPoint cCur vpt)))
       clen (distance (vlax-curve-getPointatParam cCur
                (fix (vlax-curve-getParamAtPoint cCur vpt)))
              (vlax-curve-getPointatParam cCur
                (1+ (fix (vlax-curve-getParamAtPoint cCur vpt)))))
       ParamLst (mapcar '(lambda (cVert) (vlax-curve-getParamAtPoint cCur cVert))
                (mapcar 'cdr (vl-remove-if-not
                       '(lambda (x) (= 10 (car x)))
                       (entget (car cEnt))))))
     (or (and (<= 0 VecCol 255) (setq vcol VecCol)) (setq vcol 3))
     (grtext -1 "Select Area Segregation...")
     (while (= 5 (car (setq grlist (grread t 1))))
   (redraw)
   (if (= 'list (type (setq arpt (cadr grlist))))
     (progn
       (setq spt (vlax-curve-getClosestPointto cCur arpt)
         pt1 (polar spt cAng (/ clen 3.0))
         pt2 (polar spt cAng (/ clen -3.0)))
       (grdraw pt1 pt2 vcol))))
     
     (setq iLin (vla-Addline spc (vlax-3D-point spt)
          (vlax-3D-point (polar spt cAng clen)))
       iArr (vlax-variant-value
          (vla-IntersectWith iLin cCur acExtendThisEntity)))
     (if (> (vlax-safearray-get-u-bound iArr 1) 0)
   (progn
     (setq iLst (vlax-safearray->list iArr))
     (while (not (zerop (length iLst)))
       (setq ptLst    (cons (list (car iLst) (cadr iLst) (caddr iLst)) ptLst)
         iLst    (cdddr iLst)))
     (and (vla-delete iLin) (setq iLin nil))
     
     (if (> (length ptlst) 1)
       (progn
         (setq plst  (vl-sort (list (setq int1 (vlax-curve-getParamAtPoint cCur (car ptLst)))
               (setq int2 (vlax-curve-getParamAtPoint cCur (cadr ptLst)))) '<)
           stpar (1+ (fix (car plst))))
         (while (< stpar (cadr plst))
       (setq plst (append plst (list stpar))
             stpar (1+ stpar)))
         (setq plst (vl-sort plst '<)
           vpts (apply 'append
               (mapcar '(lambda (x) (list (car x) (cadr x)))
                   (mapcar '(lambda (p)
                          (vlax-curve-getPointatParam cCur p)) plst)))
           vpts (vlax-make-variant
              (vlax-safearray-fill
                (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length vpts)))) vpts))
           aPly (vla-AddLightWeightPolyline spc vpts))
         (vla-put-closed aPly :vlax-true)
         (setq ParamLst (vl-sort
                  (append
                (vl-remove-if
                  '(lambda (param) (member param plst)) ParamLst)
                (list int1 int2)) '<)
           2vpts (apply 'append
                (mapcar '(lambda (x) (list (car x) (cadr x)))
                 (mapcar '(lambda (p)
                        (vlax-curve-getPointatParam cCur p)) ParamLst)))
           2vpts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length 2vpts)))) 2vpts))
           bPly (vla-AddLightWeightPolyline spc 2vpts))
         (vla-put-Closed bPly :vlax-true)          

         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray vlax-vbobject '(0 . 1)) (list aPly bPly))
           Regs (vlax-safearray->list
              (vlax-variant-value
                (vla-AddRegion spc ObjArr)))
           aReg (car Regs) bReg (cadr Regs))
         (mapcar 'vla-delete (list aPly bPly))
         (vla-put-color aReg acRed)
         (vla-put-color bReg acGreen)
         (setq tCenLst (mapcar '(lambda (c) (vlax-safearray->list
                       (vlax-variant-value
                         (vla-get-Centroid c)))) (list aReg bReg))
           tBox (mapcar 'textbox
                (mapcar '(lambda (str) (list (cons 1 (strcat "Area: " (rtos Str)))))
                    (setq AreaLst (mapcar 'vla-get-Area (list aReg bReg)))))
           movp (mapcar 'vlax-3d-point
                (mapcar '(lambda (x)
                       (mapcar '* (mapcar '/ (mapcar '+ (car x) (cadr x))
                           '(2.0 2.0 1.0)) '(-1.0 -1.0 1.0))) tBox))
           tCen (mapcar 'vlax-3d-point
                (mapcar 'append tCenLst (list (list 0.0) (list 0.0)))))
         (or (and (> Thtov 0.0) (setq tht Thtov)) (setq tht (getvar "TEXTSIZE")))
         (setq Area_text (mapcar 'vla-AddText (list spc spc)
                     (mapcar '(lambda (str) (strcat "Area: " (rtos str)))
                         AreaLst)
                     tCen (list tht tht)))
         (mapcar 'vla-put-color Area_text (list acRed acGreen))
         (mapcar 'vla-move Area_text (mapcar 'vlax-3d-point (list '(0 0 0) '(0 0 0))) movp)
         (if Cenpt
       (progn
         (setvar "PDMODE" 3)
         (mapcar 'vla-Addpoint (list spc spc) tCen)))

         (if CurDel (vla-Delete cCur))
         
         (princ (strcat "\n<<<  Red Area: " (rtos (car AreaLst))
                ", Green Area: " (rtos (cadr AreaLst)) " >>>")))
       
       (princ "\n<!> Selected Segregation not Closed <!>")))
   (princ "\n<!> Area Not Segregated Properly <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (grtext) (redraw)
 (princ))

(princ "\n** AreaDiv.lsp Successfully Loaded - type \"ADiv\" to invoke **") (princ)

March 24, 2009

Lee-

I wasn't sure either but stated it in my first post.

And to oliver - doesn't that first routine you posted do what you wanted? I got it to work, was a little hard to follow the prompts though.

Sign In

Cutting Area

Recommended Posts

oliver

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

CarlB

Lee Mac

oliver

Lee Mac

oliver

oliver

wizman

Lee Mac

oliver

Lee Mac

Lee Mac

oliver

Lee Mac

oliver

Lee Mac

CarlB

BIGAL

Lee Mac

CarlB

Join the conversation

Tutorials

Forums

Activity