Drawing a PLINE and getting it's area - LISP

July 20, 2010

Hi everyone!

I'm kinda new in this LISP world and I'm having some trouble on this project of mine.

Here we go:

I need a LISP to draw a PLINE and create a text with the PLINE's area.

The area is always different and I don't have the points to draw the PLINE, so I have to draw it with the mouse and when I finish I want to have the area value in a text placed inside that PLINE (I can place it with a mouse click, but I don't want to have to write the area).

This is the code I already wrote:

(defun c:AREA ()

(command "-layer" "m" "PLINES - Area" "c" "40" "" "")

(command "PLINE")

(command "AREA" "o" (entlast))

(command "text" "J" "MC" (getvar "viewctr") "0.5" "0" (getvar "area"))

(command "move" (entlast) "" (getvar "viewctr") pause)

)

I would appreciate any help!

Thanks!

July 20, 2010

I'm sur i saw something like what you want here on this site

do a search for it

July 20, 2010

Try it

(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
                whatAcadVer tstyle)

(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.0) 2010)  
((= Aver 17.2) 2009)
((= Aver 17.1) 2008)
((= Aver 17.0) 2007)
((= Aver 16.2) 2006)    
((= Aver 16.1) 2005)
((= Aver 16.0) 2004)
((= Aver 15.06) 2002)
(t 2011)
)
)
 (vl-load-com)
 (or *SCALE* (setq *SCALE* 1))
 (or *PREC* (setq *PREC* 2))
 (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
 (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
 (setq *SUFF* (vl-princ-to-string *SUFF*))
 (setq *PREF* (vl-princ-to-string *PREF*))
 (princ "\nCurrent scale = ")(princ *SCALE*)
 (princ " Current precision = ")(princ *PREC*)
 (princ " Text size = ")(princ *TEXTSIZE*)
 (princ " Prefix= ")(princ *PREF*)(princ " Suffix= ")(princ *SUFF*)
 (initget "Polyline Setting sElect _Polyline Setting sElect")
 (and
   (or ;_ 
     (> (whatAcadVer) 2005)
     (alert "\nNeed Autocad version 2006 and above")
     ) ;_
   (or ;_ 
   (while (= (setq cmdname (getkword "\nSelect or draw [Polyline/Setting/sElect] <sElect>: "))
             "Setting")
     (princ "\nNew scale <")(princ *SCALE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *SCALE* en))
     (princ "\nNew precision <")(princ *PREC*)(princ "> : ")
     (initget 4)
     (if (setq en (getint))(setq *PREC* en))
     (princ "\nNew text size <")(princ *TEXTSIZE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *TEXTSIZE* en))
     (princ "\nPrefix (space - clear) <")(princ *PREF*)(princ "> : ")
     (setq en (getstring t))(if (= en "")(setq en *PREF*))
     (if (= en " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
     (princ "\nSuffix (space - clear) <")(princ *SUFF*)(princ "> : ")
     (setq en (getstring t))(if (= en "")(setq en *SUFF*))
     (if (= en " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
     (initget "Polyline Setting sElect _Polyline Setting sElect")
     )
   t
   ) ;_ 
 (cond
   ((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
    (while (> (getvar "CMDACTIVE") 0)(command pause))
    (setq en (entlast))
    )
   ((or (null cmdname)(= cmdname "sElect"))
        (princ "\nSelect polyline, circle, spline, ellipse or arc")
        (and
          (setq tblset (ssget "_:S:E" '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
          (setq en (ssname tblset 0))
          )
    )
   (t nil)
   )
 ;_ create field
 (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
            (vl-princ-to-string(Get-ObjectID-x86-x64 (vlax-ename->vla-object en)))
               ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
               "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
               ) ;_ strcat
         ) ;_ setq
(setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_
   ;_ 
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
  (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 fld)
  (vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
  ) ;_ end of if
   (setq txt (entlast))
 (vl-cmdf "_updatefield" txt "")
 (princ "\n Pick point to insert text ot table sell:")
 (vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
 ;_ 
 (setq txt (entlast) pt (getvar "LASTPOINT"))
 (or
   (and ;_
     (setq  tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
     (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
     (mapcar '(lambda (x)
          (or tblobj
              (and
                (= :vlax-true (vla-HitTest x
                              (vlax-3d-point (trans pt 1 0))
                              (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                              'row 'col))
                (setq tblobj x)
                )
              )
          )
       lst)
     tblobj row col
     (or (vla-SetText tblobj row col fld) t)
     (entdel txt)
     )
   (and ;_
     (setq txt (vlax-ename->vla-object txt))
     (vlax-write-enabled-p txt)
     (vlax-method-applicable-p txt 'FieldCode) ;_
     (vlax-property-available-p txt 'TextString)
     (vlax-put txt 'TextString fld)
     )
   )
 )
 (princ)
 )
;;------------------------------------------------ --------
;; Function gets a string representation ObjectID
;; Whether AutoCAD x86 or x64
;; Source: https: / / discussion.autodesk.com / forums / message.jspa? MessageID = 6172961
;; Http://forum.dwg.ru/showthread.php?t=51822
(defun Get-ObjectID-x86-x64 (obj / util)
 (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
 (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
 (if (= (type obj) 'VLA-OBJECT)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
      (rtos (vla-get-objectid obj) 2 0)
    )
 )
)

Edited July 20, 2010 by VVA

July 20, 2010

Try it

Great Lisp routine Mr VVA.

Best Regards

Tharwat

July 20, 2010

Try it

(defun C:PAREATLB ( / en cmdname fld txt fc tblset tblobj row col pt
whatAcadVer tstyle)

(defun whatAcadVer ( / Aver)
(setq Aver (atof (substr (getvar "ACADVER") 1 4)))
(cond
((= Aver 18.0) 2010) 
((= Aver 17.2) 2009)
((= Aver 17.1) 2008)
((= Aver 17.0) 2007)
((= Aver 16.2) 2006) 
((= Aver 16.1) 2005)
((= Aver 16.0) 2004)
((= Aver 15.06) 2002)
(t 2011)
)
)
(vl-load-com)
(or *SCALE* (setq *SCALE* 1))
(or *PREC* (setq *PREC* 2))
(or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
(or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
(setq *SUFF* (vl-princ-to-string *SUFF*))
(setq *PREF* (vl-princ-to-string *PREF*))
(princ "\nCurrent scale = ")(princ *SCALE*)
(princ " Current precision = ")(princ *PREC*)
(princ " Text size = ")(princ *TEXTSIZE*)
(princ " Prefix= ")(princ *PREF*)(princ " Suffix= ")(princ *SUFF*)
(initget "Polyline Setting sElect _Polyline Setting sElect")
(and
(or ;_ 
(> (whatAcadVer) 2005)
(alert "\nNeed Autocad version 2006 and above")
) ;_
(or ;_ 
(while (= (setq cmdname (getkword "\nSelect or draw [Polyline/Setting/sElect] <sElect>: "))
"Setting")
(princ "\nNew scale <")(princ *SCALE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *SCALE* en))
(princ "\nNew precision <")(princ *PREC*)(princ "> : ")
(initget 4)
(if (setq en (getint))(setq *PREC* en))
(princ "\nNew text size <")(princ *TEXTSIZE*)(princ "> : ")
(initget 6)
(if (setq en (getdist))(setq *TEXTSIZE* en))
(princ "\nPrefix (space - clear) <")(princ *PREF*)(princ "> : ")
(setq en (getstring t))(if (= en "")(setq en *PREF*))
(if (= en " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
(princ "\nSuffix (space - clear) <")(princ *SUFF*)(princ "> : ")
(setq en (getstring t))(if (= en "")(setq en *SUFF*))
(if (= en " ")(setq en ""))
(if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
(setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
(initget "Polyline Setting sElect _Polyline Setting sElect")
)
t
) ;_ 
(cond
((= cmdname "Polyline")(setvar "CMDECHO" 1)(command "_.PLINE")
(while (> (getvar "CMDACTIVE") 0)(command pause))
(setq en (entlast))
)
((or (null cmdname)(= cmdname "sElect"))
(princ "\nSelect polyline, circle, spline, ellipse or arc")
(and
(setq tblset (ssget "_:S:E" '((0 . "*POLYLINE,ARC,SPLINE,ELLIPSE,CIRCLE"))))
(setq en (ssname tblset 0))
)
)
(t nil)
)
;_ create field
(setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
(vl-princ-to-string(Get-ObjectID-x86-x64 (vlax-ename->vla-object en)))
">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
"]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
) ;_ strcat
) ;_ setq
(setvar "cmdecho" 0)
(setq tstyle (getvar "TEXTSTYLE")) ;_
;_ 
(if (= (cdr (assoc 40 (tblsearch "STYLE" tstyle))) 0.0)
;; нулевая высота текста
(vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) *TEXTSIZE* 0 fld)
(vl-cmdf "_.-TEXT" "_S" tstyle "_none" '(0 0 0) 0 fld)
) ;_ end of if
(setq txt (entlast))
(vl-cmdf "_updatefield" txt "")
(princ "\n Pick point to insert text ot table sell:")
(vl-cmdf "_.copybase" (trans '(0 0 0) 0 1) txt "" "_.erase" txt "" "_.pasteclip" "_none" pause)
;_ 
(setq txt (entlast) pt (getvar "LASTPOINT"))
(or
(and ;_
(setq tblobj nil tblset (ssget "_X" '((0 . "ACAD_TABLE"))))
(setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblset)))))
(mapcar '(lambda (x)
(or tblobj
(and
(= :vlax-true (vla-HitTest x
(vlax-3d-point (trans pt 1 0))
(vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
'row 'col))
(setq tblobj x)
)
)
)
lst)
tblobj row col
(or (vla-SetText tblobj row col fld) t)
(entdel txt)
)
(and ;_
(setq txt (vlax-ename->vla-object txt))
(vlax-write-enabled-p txt)
(vlax-method-applicable-p txt 'FieldCode) ;_
(vlax-property-available-p txt 'TextString)
(vlax-put txt 'TextString fld)
)
)
)
(princ)
)
;;------------------------------------------------ --------
;; Function gets a string representation ObjectID
;; Whether AutoCAD x86 or x64
;; Source: https: / / discussion.autodesk.com / forums / message.jspa? MessageID = 6172961
;; Http://forum.dwg.ru/showthread.php?t=51822
(defun Get-ObjectID-x86-x64 (obj / util)
(setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
(if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
(if (= (type obj) 'VLA-OBJECT)
(if (> (vl-string-search "x64" (getvar "platform")) 0)
(vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
(rtos (vla-get-objectid obj) 2 0)
)
)
)

dear sir

nice program thx for sharing

it's possible

Pline area into table

Select pline (various layer for example area-1, area-2, area-e etc. )
Add area center of pline (area in sq.mt. & sq.ft.)
And total in table (various layer for example area-1, area-2, area-e etc. )

July 20, 2010

Hi,

You can look at the links given here :

http://www.cadtutor.net/forum/showthread.php?40732-Lisp-Area-from-hatches&p=274377&viewfull=1#post274377

July 20, 2010

dear sir

i want create in pline area in table

July 20, 2010

dear sir,

i found some code in my comaany server

it's not english version

PROPIEDADES_ENTIDAD.lsp

July 20, 2010

dear sir,

i found some code in my comaany server

it's not english version

The one that you have selected is French Version by Mr. gile.

Chose the first web site to get the EngliSh One .

Regards

Tharwat

July 20, 2010

The one that you have selected is French Version by Mr. gile.
Chose the first web site to get the EngliSh One .

Regards

Tharwat

dear sir

gile code is working no prob it's very good

i attched file see this

July 20, 2010

dear sir
nice program thx for sharing

it's possible

Pline area into table

Select pline (various layer for example area-1, area-2, area-e etc. )

Add area center of pline (area in sq.mt. & sq.ft.)

And total in table (various layer for example area-1, area-2, area-e etc. )

[ATTACH]21824[/ATTACH]

Do you have a specific task. If I have enough free time, try to write the program. At the present moment I have a program to capture the area of objects in the table

Command: AREATT (AREA to table)

This command allows you to insert into the specified table cell and the subsequent text field (FIELD), containing the value of the square of the selected object.

Depending on the choice of navigation options by rows or columns.

If rows or columns coming to an end, they are automatically added.

Formatting cell is taken as specified in the first cell.

Precision of rounding and scaling factor are given the option "Setting"

(defun C:AREATT ( / en obj tblobj row col lst pt rows cols what fld)
;;;; Command: AREATT (AREA to table)
;;;; Posted http://dwg.ru/f/showthread.php?t=14528
;;;; This command allows you to insert into the specified table cell and the subsequent
;;;; Text field (FIELD), containing the value of the square of the selected object.
;;;; Depending on the choice of navigation options by rows or columns.
;;;; If rows or columns coming to an end, they are automatically added.
;;;; Formatting cell is taken as specified in the first cell.
;;;; Precision of rounding and scaling factor are given the option "Setting"
;;;; Since this field is associated with a particular object, if you change 
;;;; Object field is recalculated (need updating field) 
;;;; Code can be stored in a file areatt.lsp 
;;;; Possible macro to a button or menu item: 
;;;; ^ C ^ C (if (not C: AREATT) (load "AREATT")); AREATT;  
 (vl-load-com)
 (or *SCALE* (setq *SCALE* 1))
 (or *PREC* (setq *PREC* 2))
 (or *TEXTSIZE* (setq *TEXTSIZE* (getvar "TEXTSIZE")))
 (or *SUFF* (setq *SUFF* ""))(or *PREF* (setq *PREF* ""))
 (setq *SUFF* (vl-princ-to-string *SUFF*))
 (setq *PREF* (vl-princ-to-string *PREF*))
 (princ "\nCurrent scale = ")(princ *SCALE*)
 (princ " Current precision = ")(princ *PREC*)
 (princ " Text size = ")(princ *TEXTSIZE*)
 (princ " Prefix= ")(princ *PREF*)(princ " Suffix= ")(princ *SUFF*)
 (setq  tblobj nil tblobj (ssget "_X" '((0 . "ACAD_TABLE"))))
 (setq lst (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex tblobj)))))
 (setq  tblobj nil)
 (cond
  ((and lst
        (or (initget "Row Col Setting _Row Col Setting") t)
        (or (while (=(setq what (getkword "\nNavigate [on tne Row/on the Columns/Setting] <on the Columns>: "))
                     "Setting")
                    (princ "\nNew scale <")(princ *SCALE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *SCALE* en))
     (princ "\nNew  precision <")(princ *PREC*)(princ "> : ")
     (initget 4)
     (if (setq en (getint))(setq *PREC* en))
     (princ "\nNew text size <")(princ *TEXTSIZE*)(princ "> : ")
     (initget 6)
     (if (setq en (getdist))(setq *TEXTSIZE* en))
     (princ "\nPrefix (space - clear) <")(princ *PREF*)(princ "> : ")
     (if (= (setq en (getstring t)) " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *PREF* en)
     (princ "\nSuffixс (space - clear) <")(princ *SUFF*)(princ "> : ")
     (if (= (setq en (getstring t)) " ")(setq en ""))
     (if (= (substr (vl-string-left-trim "\/" en) 1 2) "U+")
     (setq en (strcat "\\" (vl-string-left-trim "\/" en))))(setq *SUFF* en)
              (initget "Row Col Setting _Row Col Setting")
              )
            t
            )
        (or what (setq what "Col"))
        (or
       (while (null  tblobj)
         (initget 1)
         (setq pt (getpoint "\nSpecify a first table cell:"))
         (mapcar '(lambda (x)
          (or tblobj
              (and
                (= :vlax-true (vla-HitTest x
                              (vlax-3d-point (trans pt 1 0))
                              (vlax-3d-point (trans (getvar "VIEWDIR") 1 0))
                              'row 'col))
                (setq tblobj x)
                )
              )
          )
       lst)
         (if (null  tblobj)(princ " ** missing **"))
         )
       t)
        (or
          (vlax-write-enabled-p tblobj)
          (and
            (princ "\nTable on a locked layer!")
            nil
            )
          )
        (setq pt (vla-GetCellAlignment tblobj row col))
        )
   (setq rows (vla-get-rows tblobj))
   (setq cols (vla-get-columns tblobj))
   (while (setq en (car (entsel "\nSelect the entity to insert it square into the table (ENTER - exit): " )))
     (cond
      ((vlax-property-available-p (setq en (vlax-ename->vla-object en)) 'Area)
         (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
            (vl-princ-to-string(Get-ObjectID-x86-x64 en))
               ">%).Area \\f \"%lu2%ps["*PREF* "," *SUFF*
               "]%pr"(itoa *PREC*) "%ct8["(vl-princ-to-string *SCALE*)"]\">%"
               ) ;_ strcat
         )
       (cond
         ((= col cols)
           (vla-insertColumns tblobj col (vla-GetColumnWidth tblobj (1- col)) 1)
           (vla-SetCellAlignment tblobj row col pt)
           (setq rows (vla-get-rows tblobj))
           (setq cols (vla-get-columns tblobj))
           
         )
         ((= row rows)
           (vla-insertRows tblobj row (vla-GetRowHeight tblobj (1- row)) 1)
          (vla-SetCellAlignment tblobj row col pt)
           (setq rows (vla-get-rows tblobj))
           (setq cols (vla-get-columns tblobj))
        )
         (t nil))
       (vla-SetText tblobj row col fld)
       (if (= what "Col")(setq col (1+ col))(setq row (1+ row)))
       
      )
      (t(princ "\nThis primitive can not get property Area!"))
     )
     
   )
  )
  (t
    (princ "\nTables not found!")
  )
 )
 (princ)
)
;;------------------------------------------------ --------
;; Function gets a string representation ObjectID
;; Whether AutoCAD x86 or x64
;; Source: https: / / discussion.autodesk.com / forums / message.jspa? MessageID = 6172961
;; Http://forum.dwg.ru/showthread.php?t=51822
(defun Get-ObjectID-x86-x64 (obj / util)
 (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
 (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
 (if (= (type obj) 'VLA-OBJECT)
    (if (> (vl-string-search "x64" (getvar "platform")) 0)
      (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
      (rtos (vla-get-objectid obj) 2 0)
    )
 )
)

July 21, 2010

VVA,

Thanks for your code! It really helped me!!!

July 21, 2010

Do you have a specific task. If I have enough free time, try to write the program. At the present moment I have a program to capture the area of objects in the table
QUOTE]

Dear Sir

Thx For Reply

appreciate u r attitude thx agian

Sign In

Drawing a PLINE and getting it's area - LISP

Recommended Posts

linuxap

JohnM

VVA

Tharwat

sachindkini

gile

sachindkini

sachindkini

Tharwat

sachindkini

VVA

linuxap

sachindkini

Join the conversation

Tutorials

Forums

Activity