Cutting Area

March 24, 2009

Carl, does my routine work for you?

March 24, 2009

A slight variation:

;;;=======================================================
;;;=======================================================
;;;
;;;  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 Partition: "))
      (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)
         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))
       (grdraw (car ptLst) (cadr ptLst) 3))))))
     
     (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<!> 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

A few comments in the attached file.

Great job BTW.

Next challange would be to allow the user to pick the segment & enter the desired area. Lisp will create the plines required to get that area.

Sorry but I've got to run..

Area Cut by LM.LSP

March 24, 2009

A few comments in the attached file.
Great job BTW.

Next challange would be to allow the user to pick the segment & enter the desired area. Lisp will create the plines required to get that area.

Sorry but I've got to run..

nothing has change...same as what lee mac did.

March 24, 2009

nothing has change...same as what lee mac did.

CAB was only commenting on the format of my code

March 24, 2009

Lee-

yours works, erratically. Dividing line doesn't follow the cursor, jumps around, seems better if dividing line is more horizontal. Last version deleted the original polyline.

Oliver-

Doesn't the first routine you posted work for you? It did for me, somewhat.

March 24, 2009

Lee-
yours works, erratically. Dividing line doesn't follow the cursor, jumps around, seems better if dividing line is more horizontal.

Yes, I preffered the version before the "variation" - where there was a single vector at the same angle as one of the sides.

But to make the new variation work more smoothly - just put the cursor outside or close to the curve when choosing the partition area - as the function using vlax-curve-getClosestPointto, so it gets a bit erratic when you are near the midpoint of the two sides.

Last version deleted the original polyline.

Yes, I added a few adjustments at the top of the LISP. See there.

March 24, 2009

A few comments in the attached file.
Great job BTW.

Next challange would be to allow the user to pick the segment & enter the desired area. Lisp will create the plines required to get that area.

Sorry but I've got to run..

Ahhh, many thanks for the help CAB - all very much self explanatory.

I am just getting to grips with this VL coding ~ I set myself a challenge, not to resort to calling ACAD commands in the LISP, so I made the LWPLINEs "from scratch".

It was a stupid mistake with the (mapcar 'setvar vlst '(0 0)), which tbh happened because I quickly decided to make a few changes to the code last minute to add the points at the centroids.

Thanks once again

Lee

March 26, 2009

Try this ~ extremely temperamental!

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


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

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

 (setq CurDel nil) ;  Delete Original Region

 (setq Cenpt nil) ;  Points at Region Centroids

 (setq Thtov 0.0) ;  Text Height Override

 (setq Acc 10.0) ;  Tolerance

 (setq Inc 0.01) ; Incremental Step

 ; ========================

 (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 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 to Measure From: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car cEnt))))))
   (progn
     (vla-EndUndoMark doc)
     (vla-StartUndoMark doc)
     (setq cCur (vlax-ename->vla-object (car cEnt)))
     (vla-put-closed cCur :vlax-true)
     (setq vpt     (vlax-curve-getClosestPointTo (car cEnt) (cadr cEnt))
       pap     (vlax-curve-getParamAtPoint cCur vpt)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cCur pap))
       clen (- (vlax-curve-getDistatParam cCur (1+ (fix pap)))
           (vlax-curve-getDistatParam cCur (fix pap))))
     (setq ParamLst (list (vlax-curve-getendparam cCur)))
     (repeat (fix (car ParamLst))
   (setq ParamLst (cons (1- (car ParamLst)) ParamLst)))
     (if (and (not (initget 7))
          (setq rArea (getreal "\nSpecify Required Area: "))
          (<= rArea (vla-get-Area cCur)))
   (progn
     (setq    Area 0.0
       i    1.0)
     (while (and (not (equal Area rArea Acc))
             (setq spt (vlax-curve-getPointatParam cCur (* i Inc))))
       (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)
           (vla-put-color aPly acGreen)
           (setq Area    (vla-get-Area aPly)
             ptLst    nil
             plst    nil)
           (or (equal Area rArea Acc) (vla-delete aPly))
           (setq i (1+ i)))))))

     (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))
     (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 '((0.0) (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 '((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))
            " >>>"))
     (vla-EndUndoMark doc))
   (princ "\n<!> Area Specified Exceeds Main Area <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

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

March 26, 2009

Actually, this is probably better:

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


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

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

 (setq CurDel nil) ;  Delete Original Region

 (setq Cenpt nil) ;  Points at Region Centroids

 (setq Thtov 0.0) ;  Text Height Override

 (setq Acc 10.0) ;  Tolerance

 (setq Inc 0.01) ; Incremental Step

 (setq 2Areas nil)  ; Two Marked Areas

 ; ========================

 (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 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 to Measure From: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car cEnt))))))
   (progn
     (vla-EndUndoMark doc)
     (vla-StartUndoMark doc)
     (setq cCur (vlax-ename->vla-object (car cEnt)))
     (vla-put-closed cCur :vlax-true)
     (setq vpt     (vlax-curve-getClosestPointTo (car cEnt) (cadr cEnt))
       pap     (vlax-curve-getParamAtPoint cCur vpt)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cCur pap))
       clen (- (vlax-curve-getDistatParam cCur (1+ (fix pap)))
           (vlax-curve-getDistatParam cCur (fix pap))))
     (setq ParamLst (list (vlax-curve-getendparam cCur)))
     (repeat (fix (car ParamLst))
   (setq ParamLst (cons (1- (car ParamLst)) ParamLst)))
     (setq Main_Area (vla-get-area cCur))
     (if (and (not (initget 7))
          (setq rArea (getreal (strcat "\nArea of Curve: " (rtos Main_Area)
                       " Specify Required Area: ")))
          (<= rArea Main_Area))
   (progn
     (setq    Area 0.0
       i    1.0)
     (while (and (not (equal Area rArea Acc))
             (setq spt (vlax-curve-getPointatParam cCur (* i Inc))))
       (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)
           (vla-put-color aPly acGreen)
           (setq Area    (vla-get-Area aPly)
             ptLst    nil
             plst    nil)
           (or (equal Area rArea Acc) (vla-delete aPly))
           (setq i (1+ i)))))))

     (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))
     (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 '((0.0) (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 '((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)) " >>>"))
     (mapcar 'vla-delete (list aPly bPly))
     (if (not 2Areas) (mapcar 'vla-delete (list (car Area_text) aReg)))
     (vla-EndUndoMark doc))
   (princ "\n<!> Area Specified Exceeds Main Area <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

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

March 26, 2009

@ Lee, you been doing a hard work..sorry to bother you..but the last routine lisp not workin...

good day

oliver

March 26, 2009

Yeah, sorry bout that, I'm working on it

March 26, 2009

Ok give this a shot, I've simplified it but it still isn't perfect:

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


(defun c:ADiv  (/    *error*    vlst    ovar    doc    spc    cEnt    ParamLst    Main_Area    rArea    vpt
       cCur    cAng    clen    spt    iLin    iArr    iLst    ptLst    plst    stpar    vpts    aPly    int1
       int2    Acc    Inc)

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

 (setq Acc 10.0) ;  Tolerance

 ; ========================

 (vl-load-com)

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

 (setq    vlst '("OSMODE")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar vlst '(0 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 to Measure From: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car cEnt))))))
   (progn
     (vla-EndUndoMark doc)
     (vla-StartUndoMark doc)
     (setq cCur (vlax-ename->vla-object (car cEnt)))
     (vla-put-closed cCur :vlax-true)
     (setq vpt     (vlax-curve-getClosestPointTo (car cEnt) (cadr cEnt))
       pap     (vlax-curve-getParamAtPoint cCur vpt)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cCur pap))
       clen (- (vlax-curve-getDistatParam cCur (1+ (fix pap)))
           (vlax-curve-getDistatParam cCur (fix pap))))
     (setq ParamLst (list (vlax-curve-getendparam cCur)))
     (repeat (fix (car ParamLst))
   (setq ParamLst (cons (1- (car ParamLst)) ParamLst)))
     (setq Main_Area (vla-get-area cCur))
     (if (and (not (initget 7))
          (setq rArea (getreal (strcat "\nArea of Curve: " (rtos Main_Area)
                       " Specify Required Area: ")))
          (<= rArea Main_Area))
   (progn
     (setq    Area 0.0 i 1.0 Inc (/ Acc 100.0))
     (while (and (not (equal Area rArea Acc))
             (setq spt (vlax-curve-getPointatParam cCur (* i Inc))))
       (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)
           (vla-put-color aPly acGreen)
           (setq Area    (vla-get-Area aPly)
             ptLst    nil
             plst    nil)
           (or (equal Area rArea Acc) (vla-delete aPly))
           (setq i (1+ i)))))))
     (princ (strcat "\nArea of Green Region: " (rtos Area)))
     (vla-EndUndoMark doc))
   (princ "\n<!> Area Specified Exceeds Main Area <!>")))
   (princ "\n<!> Nothing Selected or this isn't an LWPLINE <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

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

March 27, 2009

Lee I was going to look at this today but had no time. I did come up with an alternate

user input that you may consider. Maybe some time tomorrow.

  ;;  Get Pline & segment from user, ESC to abort
 (while
   (not
     (and
       (setq cEnt (entsel "\nSelect Edge to Measure From: "))
       (setq cCur (vlax-ename->vla-object (car cEnt)))
       (or (eq (vla-get-ObjectName cCur) "AcDbPolyline")
           (prompt "\nNot a pline, Try again.")
       )
       (if (eq (vla-get-closed cCur) :vlax-true)
         t                             ; exit loop
         (if (or (initget "Yes No")
                 (/= (getkword "\nClose Pline? <Y>: ") "No")
             )
           (null (vla-put-closed cCur :vlax-true)) ; exit loop
           (prompt "\nPick a closed pline.")
         )
       )
     )
   )
 )

 ;;  Get the area desired by user, ESC to abort
 (setq cAre    (vla-get-Area cCur)
       MaxArea (rtos cAre 2 0)         ; need subroutine to alter units to desires area
 )
 (while
   (progn
     (initget 7)
     (setq
       rArea (getreal (strcat "\nSpecify Required Area (max=" MaxArea "): "))
     )
     (if (>= rArea cAre)
       (princ "\nArea too large, Try again.")
     )
   )
 )

March 27, 2009

Lee I was going to look at this today but had no time. I did come up with an alternate

user input that you may consider. Maybe some time tomorrow.

  ;;  Get Pline & segment from user, ESC to abort
 (while
   (not
     (and
       (setq cEnt (entsel "\nSelect Edge to Measure From: "))
       (setq cCur (vlax-ename->vla-object (car cEnt)))
       (or (eq (vla-get-ObjectName cCur) "AcDbPolyline")
           (prompt "\nNot a pline, Try again.")
       )
       (if (eq (vla-get-closed cCur) :vlax-true)
         t                             ; exit loop
         (if (or (initget "Yes No")
                 (/= (getkword "\nClose Pline? <Y>: ") "No")
             )
           (null (vla-put-closed cCur :vlax-true)) ; exit loop
           (prompt "\nPick a closed pline.")
         )
       )
     )
   )
 )

 ;;  Get the area desired by user, ESC to abort
 (setq cAre    (vla-get-Area cCur)
       MaxArea (rtos cAre 2 0)         ; need subroutine to alter units to desires area
 )
 (while
   (progn
     (initget 7)
     (setq
       rArea (getreal (strcat "\nSpecify Required Area (max=" MaxArea "): "))
     )
     (if (>= rArea cAre)
       (princ "\nArea too large, Try again.")
     )
   )
 )

Thanks CAB,

Its quite similar to the user input in my routine, but coded in a much more elegant way

Thanks.

The problem I am facing is within the while statement, when finding region of the desired area, the program will sometimes quit without finding the area... I think this is to do with which edge the user selects. But I can't seem to figure out how to get round it

Cheers

Lee

March 29, 2009

Ok here is an updated version ~ this should work better (hopefully!)

;;;================= AreaDiv.lsp =================
;;;
;;; FUNCTION: AD (Area Division)
;;;
;;; Will Divide a Selected LWPolyline into
;;; a specified Area and remainder.
;;;
;;; AUTHOR:
;;; Copyright (C) 2009 Lee McDonnell
;;;  (Contact Lee Mac, CADTutor.net)
;;;
;;; PLATFORMS:
;;; No Restrictions, only tested on ACAD2004
;;;
;;; VERSION:
;;; 1.0   ~   29.03.2009
;;;
;;;===============================================


(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Ent cEnt cPt cAng p@sel cLen mArea ePara
          Paralst rArea pArea pInc i vPt tLine iArr iLst
          ptLst pLst sPara vpLst vPts tPoly 2vPts 2tPoly)

 ; === Adjustments ===

 (setq ODel nil)    ;  Delete Original LWPolyline (T = Del)

 (setq Acc 5.0)  ;  Accuracy of Area Retrieval

 (setq ACol 3)    ;  Colour of Desired Region (0-255)

 (setq BCol 4)    ;  Colour of Second Region (if 2Area = T)

 (setq 2Area nil)   ;  Secondary Marked Area (T or nil)

 ; ===================

 ; === Error Prevention ===

 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (<= 0 ACol 255) (setq ACol 3))
 (or (<= 0 BCol 255) (setq BCol 4))

 (defun *error* (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 ; ========================

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

 (setq vlst '("OSMODE" "PDMODE")
   ovar (mapcar 'getvar vlst))

 (if (and (setq Ent (entsel "\nSelect LWPolyline: "))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car Ent))))))
   (progn
     (setq cEnt (vlax-ename->vla-object (car Ent))
       cPt (vlax-curve-getClosestPointto cEnt (cadr Ent) acExtendNone)
       cAng (angle '(0 0 0) (vlax-curve-getFirstDeriv cEnt
                  (vlax-curve-getParamatPoint cEnt cPt)))
       p@sel (vlax-curve-getParamAtPoint cEnt cPt)
       cLen (- (vlax-curve-getDistatParam cEnt (fix p@sel))
           (vlax-curve-getDistatParam cEnt (1+ (fix p@sel)))))
     (if (eq :vlax-false (vla-get-Closed cEnt))
   (progn
     (initget "Yes No")
     (if (eq "Yes" (getkword "\nPolyline Not Closed, Close it?  "))
       (vla-put-Closed cEnt :vlax-true))))
     (setq mArea (vla-get-Area cEnt) ePara (1+ (vlax-curve-getEndParam cEnt)))
     (while (not (minusp (setq ePara (1- ePara))))
   (setq Paralst (cons ePara Paralst)))
     (if (and (not (initget 7))
          (setq rArea (getreal (strcat "\nPline Area: "(rtos mArea 2 0)", Required: ")))
          (<= rArea mArea))
   (progn
     (setq pArea 0.0 pInc (/ Acc 500.0) i -1.0)

     ; === While Loop ===

     (while (and (not (equal rArea pArea Acc))
             (setq vPt (vlax-curve-getPointatParam cEnt (* pInc (setq i (1+ i))))))
       (setq tLine (vla-addLine spc (vlax-3D-Point vPt)
             (vlax-3D-Point (polar vPt cAng cLen)))
         iArr (vlax-variant-value
            (vla-IntersectWith tLine cEnt acExtendThisEntity)))
       (vla-Delete tLine)
       (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)))))
       (if (> (length ptLst) 1)
         (progn
       (setq pLst (vl-sort
                (mapcar
                  '(lambda (p) (vlax-curve-getParamatPoint cEnt p)) ptLst) '<)
             sPara (1+ (fix (car pLst))) pInts (list (car pLst) (cadr pLst)))
       (while (< sPara (cadr pLst))
         (setq pLst (append pLst (list sPara)) sPara (1+ sPara)))
       (setq vpLst (apply 'append
                 (mapcar '(lambda (x) (list (car x) (cadr x)))
                     (mapcar '(lambda (p) (vlax-curve-getPointatParam cEnt p)) (vl-sort pLst '<))))
             vPts (vlax-make-variant
                (vlax-safearray-fill
                  (vlax-make-safearray
                vlax-vbdouble
                (cons 0 (1- (length vpLst))))
                  vpLst))
             tPoly (vla-AddLightWeightPolyline spc vPts))
       (vla-put-Closed tPoly :vlax-true)
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (vla-Delete tPoly))))
       (setq ptLst nil))

       ; === End of Loop ===

     (if tPoly
       (progn
         (vla-put-color tPoly ACol)
         (if 2Area
       (progn
         (setq Paralst (apply 'append
                  (mapcar '(lambda (w) (list (car w) (cadr w)))
                      (mapcar '(lambda (y) (vlax-curve-getPointatParam cEnt y))
                          (vl-sort
                            (append pInts (vl-remove-if
                                    '(lambda (m) (member m pLst)) Paralst)) '<))))
           2vPts (vlax-make-variant
               (vlax-safearray-fill
                 (vlax-make-safearray
                   vlax-vbDouble
                   (cons 0 (1- (length Paralst))))
                 Paralst))
           2tPoly (vla-addLightWeightPolyline spc 2vPts))
         (vla-put-Closed 2tPoly :vlax-true)
         (vla-put-Color 2tPoly BCol)))

         (if ODel (vla-Delete cEnt)))

       (princ "\n<!> Unable to Partition Area <!>")))
   (princ "\n<!> Area is Greater than Area of Selected Pline <!>")))
   (princ "\n<!> Nothing Selected, or this isn't an LWPline <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

March 29, 2009

See here for most updated version:

http://www.cadtutor.net/forum/showthread.php?t=34364

February 17, 2016

Maybe this?
...

Hi Lee Mac,

I'm looking for somthing like this...

But i want to divide an area in equal areas over an axis.

Can you help me with that?

Thnx

EddyBeerke

February 17, 2016

HI EFL,

see if this can help you...

http://www.cadtutor.net/forum/showthread.php?82140-Area-split-equal./page5&p=#42

M.R. Cheers...

Sign In

Cutting Area

Recommended Posts

Lee Mac

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Lee Mac

CAB

oliver

Lee Mac

CarlB

Lee Mac

Lee Mac

Lee Mac

Lee Mac

oliver

Lee Mac

Lee Mac

CAB

Lee Mac

Lee Mac

Lee Mac

EFL

marko_ribar

Join the conversation

Tutorials

Forums

Activity