Autocad Application: Object Was Erased

March 29, 2009

Hi All,

I have just finished writing the LISP as shown below, and am currently testing it.

I keep receiving a temperamental Error Message that will sometimes show and at other times the LISP will complete successfully.

But I can't for the life of me work out what is going wrong sometimes.

Any help is much appreciated - and I thank you for your time.

;;;================= 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
          Txt tAcc tHt TCol 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
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)

 ; === Adjustments ===

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

 (setq Acc 5.0)  ;  Accuracy of Area Retrieval (Tolerance)

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

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

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

 (setq Txt T)     ;  Area Text in Regions (T or nil)

 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)

 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)

 (setq TCol 2)    ;  Area Text Colour (if Txt = T)

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

 ; === Error Prevention ===

 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))

 (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")
   ovar (mapcar 'getvar vlst))

 (mapcar 'setvar vlst '(0))

 (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) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))

         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr)))
           rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (vla-delete tPoly))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))

         (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

Use (if(not(vlax-erased-p tPoly)) to will be convinced that your polyline isn't erased or use (setq tPoly nil) after (vla-Delete tPoly).

Usage of (vla-Delete tPoly) will not change tPoly variable value.

March 29, 2009

Use (if(not(vlax-erased-p tPoly)) to will be convinced that your polyline isn't erased or use (setq tPoly nil) after (vla-Delete tPoly).

Usage of (vla-Delete tPoly) will not change tPoly variable value.

Ahh good point!

I suppose, as its an iterative process - there is a chance that the area will not be found within the Tolerance (Acc) - but as tPoly is not set to nil, the LISP will still try to proceed...

Many thanks ASMI - will give that a go

Cheers

Lee

March 29, 2009

Many thanks ASMI - vlax-erased-p works a treat.

March 29, 2009

Found a few other glitches, like the areas being labelled the wrong way round, but all seems to be fixed now

It sometimes can't partition the region, I think because (being an iterative process), the area doesnt come to within the tolerance set before the loop gets to the end of the curve - but decreasing the incremental step will only slow the program down.

But anyway, here is a final result:

;;;================= 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
;;;
;;; RESTRICTIONS:
;;; Iterative Process, will unsuccessfully
;;; partition region if tolerance is too low.
;;;
;;;===============================================


(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Txt tAcc tHt TCol 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
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)

 ; === Adjustments ===

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

 (setq Acc 5.0)  ;  Accuracy of Area Retrieval (Tolerance)

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

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

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

 (setq Txt T)     ;  Area Text in Regions (T or nil)

 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)

 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)

 (setq TCol 2)    ;  Area Text Colour (if Txt = T)

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

 ; === Error Prevention ===

 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))

 (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")
   ovar (mapcar 'getvar vlst))

 (mapcar 'setvar vlst '(0))

 (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)))
       (and (vla-Delete tLine) (setq tLine nil))
       (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))
       (if (not (vlax-erased-p tPoly)) (vla-put-Closed tPoly :vlax-true))
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (and (vla-Delete tPoly) (setq tPoly nil)))))
       (setq ptLst nil))

       ; === End of Loop ===


     (if (not (vlax-erased-p 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) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))

         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr))))
         
         (if (< 1 (length ObjReg))
           (setq ObjReg (vl-sort ObjReg '(lambda (x1 x2)
                           (< (abs (- rArea (vla-get-Area x1)))
                              (abs (- rArea (vla-get-Area x2))))))))
                     
         (setq rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (and (vla-delete tPoly) (setq tPoly nil)))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))

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

PS. got the idea for the "textbox" method for positioning the text from your legendary "Talon" LISP ~ thanks

March 30, 2009

Found a few other glitches, like the areas being labelled the wrong way round, but all seems to be fixed now

It sometimes can't partition the region, I think because (being an iterative process), the area doesnt come to within the tolerance set before the loop gets to the end of the curve - but decreasing the incremental step will only slow the program down.

But anyway, here is a final result:

;;;================= 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
;;;
;;; RESTRICTIONS:
;;; Iterative Process, will unsuccessfully
;;; partition region if tolerance is too low.
;;;
;;;===============================================


(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Txt tAcc tHt TCol 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
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)

 ; === Adjustments ===

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

 (setq Acc 5.0)  ;  Accuracy of Area Retrieval (Tolerance)

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

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

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

 (setq Txt T)     ;  Area Text in Regions (T or nil)

 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)

 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)

 (setq TCol 2)    ;  Area Text Colour (if Txt = T)

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

 ; === Error Prevention ===

 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))

 (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")
   ovar (mapcar 'getvar vlst))

 (mapcar 'setvar vlst '(0))

 (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)))
       (and (vla-Delete tLine) (setq tLine nil))
       (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))
       (if (not (vlax-erased-p tPoly)) (vla-put-Closed tPoly :vlax-true))
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (and (vla-Delete tPoly) (setq tPoly nil)))))
       (setq ptLst nil))

       ; === End of Loop ===


     (if (not (vlax-erased-p 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) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))

         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr))))
         
         (if (< 1 (length ObjReg))
           (setq ObjReg (vl-sort ObjReg '(lambda (x1 x2)
                           (< (abs (- rArea (vla-get-Area x1)))
                              (abs (- rArea (vla-get-Area x2))))))))
                     
         (setq rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (and (vla-delete tPoly) (setq tPoly nil)))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))

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

PS. got the idea for the "textbox" method for positioning the text from your legendary "Talon" LISP ~ thanks

nice to back here...by the way..we been missin..for two days i thinkl..

@ Lee..i got trouble..

Command: ad

Select LWPolyline:
Pline Area: 3312, Required: 1500

<!> Unable to Partition Area <!>

Command:
Command:
Command: _.erase 1 found

Command: re
REGEN Regenerating model.

Command: ad

Select LWPolyline:
Pline Area: 6706, Required: 3000

<!> Unable to Partition Area <!>

Command:

March 30, 2009

;;;================= AreaDiv.lsp =================
;;;
;;; FUNCTION: AD (Area Division)
;;;
;;; Will Divide a Selected LWPolyline into
;;; a specified Area and remainder.
;;;
;;; AUTHOR:
;;; Copyright © 2009 Lee McDonnell
;;;  (Contact Lee Mac, CADTutor.net)
;;;
;;; PLATFORMS:
;;; No Restrictions, only tested on ACAD2004
;;;
;;; VERSION:
;;; 1.0   ~   29.03.2009
;;;
;;; [color=Red][b]RESTRICTIONS:
;;; Iterative Process, will unsuccessfully
;;; partition region if tolerance is too low.[/b][/color]
;;;
;;;===============================================
 
Yes, that is no error - this is an iterative process - it wont find the area everytime - need to fiddle with the incremental step and tolerance.
 
I shall post a slower but more accurate program.

March 30, 2009

;;;================= 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
;;;
;;; RESTRICTIONS:
;;; Iterative Process, will unsuccessfully
;;; partition region if tolerance is too low.
;;;
;;;===============================================


(defun c:AD (/ *error* ovar vlst doc spc ODel Acc ACol BCol 2Area
          Txt tAcc tHt TCol 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
          RLst ObjArr ObjReg rCentr tBoxes mOvPt txtObj AreaLst)

 ; === Adjustments ===

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

 (setq Acc 1.0)  ;  Accuracy of Area Retrieval (Tolerance)

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

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

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

 (setq Txt T)     ;  Area Text in Regions (T or nil)

 (setq tAcc 2)    ;  Area Text Precision (if Txt = T)

 (setq tHt 2.5)   ;  Area Text Height (if Txt = T, 0.0 for Default)

 (setq TCol 2)    ;  Area Text Colour (if Txt = T)

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

 ; === Error Prevention ===

 (or (< 0.0 Acc) (setq Acc 10.0))
 (or (and (eq 'INT (type ACol)) (<= 0 ACol 255)) (setq ACol 3))
 (or (and (eq 'INT (type ACol)) (<= 0 BCol 255)) (setq BCol 4))
 (or (and (eq 'INT (type tAcc)) (<= 0 tAcc))     (setq tAcc 2))
 (or (and (eq 'INT (type TCol)) (<= 0 TCol 255)) (setq TCol 2))
 (or (< 0.0 tHt) (setq tHt (getvar "TEXTSIZE")))

 (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")
   ovar (mapcar 'getvar vlst))

 (mapcar 'setvar vlst '(0))

 (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 1000.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)))
       (and (vla-Delete tLine) (setq tLine nil))
       (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))
       (if (not (vlax-erased-p tPoly)) (vla-put-Closed tPoly :vlax-true))
       (setq pArea (vla-get-Area tPoly))
       (or (equal rArea pArea Acc) (and (vla-Delete tPoly) (setq tPoly nil)))))
       (setq ptLst nil))

       ; === End of Loop ===


     (if (not (vlax-erased-p 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) (setq RLst (list tPoly 2tPoly)))
       (setq RLst (list tPoly)))

         (if Txt
       (progn
         (setq ObjArr (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0 (1- (length RLst))))
                RLst)
           ObjReg (vlax-safearray->list
                (vlax-variant-value
                  (vla-addRegion spc ObjArr))))
         
         (if (< 1 (length ObjReg))
           (setq ObjReg (vl-sort ObjReg '(lambda (x1 x2)
                           (< (abs (- rArea (vla-get-Area x1)))
                              (abs (- rArea (vla-get-Area x2))))))))
                     
         (setq rCentr (mapcar '(lambda (x) (vlax-safearray->list
                             (vlax-variant-value
                           (vla-get-Centroid x)))) ObjReg)
           tBoxes (mapcar '(lambda (x) (textbox (list (cons 1 x))))
                      (setq AreaLst (mapcar '(lambda (y) (strcat "Area: " (rtos y 2 tAcc)))
                                (mapcar 'vla-get-Area RLst))))
           mOvPt  (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))) tBoxes))
           rCentr (mapcar 'vlax-3D-Point
                      (mapcar '(lambda (x) (append x '(0.0))) rCentr))
           txtObj (mapcar '(lambda (x y) (vla-addText spc x y tHt)) AreaLst rCentr))
         
         (cond ((eq 1 (length RLst))
            (vla-Move (car txtObj) (vlax-3D-Point '(0 0 0)) (car mOvPt))
            (vla-put-Color (car txtObj) TCol)
            (vla-put-Color (car ObjReg) ACol)
            (and (vla-delete tPoly) (setq tPoly nil)))
           ((eq 2 (length RLst))
            (mapcar 'vla-Move txtObj
                (mapcar 'vlax-3D-Point '((0 0 0) (0 0 0))) mOvPt)
            (mapcar 'vla-put-Color txtObj (list TCol TCol))
            (mapcar 'vla-put-Color ObjReg (list ACol BCol))
            (mapcar 'vla-Delete (list tPoly 2tPoly))))))

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

April 1, 2009

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

i am using autodesk land desktop 2009..

April 1, 2009

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

i am using autodesk land desktop 2009..

It should work on that - but as I have said earlier - the tolerance and incremental step need to be adjusted to help it to retrieve the required area consistently.

April 4, 2009

finally..now its work downgrade to acad2007..

thank you..

oliver

April 4, 2009

finally..now its work downgrade to acad2007..
thank you..

oliver

Glad you got it working - I don't like the iterative methods for functions - they are mostly unreliable and the reliability can vary somewhat depending on the user inputs... for example, in my code, it would struggle to find a small area in a large region, and the tolerance and incremental step would have to be greatly modified.

But I think this method is the best you are going to get for this request, I certainly cannot think of another method of performing such a task, and I would be interested if anyone else could....

Cheers

Lee

April 4, 2009

I’ve been watching this and the related thread but have not been able to add much due to limited Lisp experience. I can certainly see the complexity of the situation, however.

After further pondering, I’d be interested to know how the process would deal with the situation illustrated here, and in simplified form below.

In the “simplified”, there seems to be a discontinuity in a target area from 60 and 64 square units.

April 4, 2009

Yes, I had that on my mind too Sean, I am finding the intersection between a line parallel to one of the edges of the original region, and the region itself - but I only use the first two intersections, hence only focussing on shapes that aren't concave at any point (if that makes sense).

I suppose I could add a bit of code that says something like, "if the intersection list is greater than two, then ignore vertices between every other point, but then this still would become complicated for more complex shapes.

April 5, 2009

I guess this is a good example of how programs can continue increasing in complexity to account for situations that are increasingly unlikely to occur. A line has to be drawn somewhere, as they say. Nice routine.

April 5, 2009

Cheers Sean, I agree - I could go on all day with this one, trying to think up more and more complex shapes to test it on - I suppose you could also include a quick test to find all self-intersections, so that you can't test on objects that intersect themselves.

April 5, 2009

Perhaps this, to test for self-intersections:

AreaDiv (Area Specification).lsp

August 27, 2009

Dear Lee ,

convert areadiv.lsp to delphi or c# code?

August 27, 2009

Dear Lee ,

convert areadiv.lsp to delphi or c# code?

If I had the knowledge buddy...

August 27, 2009

I writing split polygon code in delphi but split must parallel to a side on polygon? like image in #13 post

Sign In

Autocad Application: Object Was Erased

Recommended Posts

Lee Mac

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Lee Mac

Posted Images

ASMI

Lee Mac

Lee Mac

Lee Mac

oliver

Lee Mac

Lee Mac

oliver

Lee Mac

oliver

Lee Mac

SEANT

Lee Mac

SEANT

Lee Mac

Lee Mac

gokhandogru

Lee Mac

gokhandogru

Join the conversation

Lee Mac

Tutorials

Forums

Activity