Jump to content

Autocad Application: Object Was Erased

Lee Mac

By Lee Mac
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Lee Mac Grand Master

Lee Mac

Posted
Posted

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

Link to comment
Share on other sites
  • Replies 20
  • Created
  • Last Reply

Top Posters In This Topic

  • Lee Mac

    12

  • oliver

    3

  • SEANT

    2

  • gokhandogru

    2

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Lee Mac
Lee Mac

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.

Posted Images

ASMI Proficient

ASMI

Posted
Posted

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.

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted
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

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted

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

Link to comment
Share on other sites
oliver Contributor

oliver

Posted
Posted
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:

:(

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted 
;;;================= 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.
Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted 
;;;================= 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))

Link to comment
Share on other sites
oliver Contributor

oliver

Posted
Posted 

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

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted 
;;; 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.

  • Thanks 1
Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted
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.... :P

 

Cheers

 

Lee

Link to comment
Share on other sites
SEANT Veteran

SEANT

Posted
Posted

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.

cuttingarea2.jpg

Simplified.jpg

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted

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. :(

Link to comment
Share on other sites
SEANT Veteran

SEANT

Posted
Posted

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.

Link to comment
Share on other sites
Lee Mac Grand Master

Lee Mac

Posted
  • Author
Posted

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.

Link to comment
Share on other sites
  • 4 months later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...