Jump to content

Drawing a PLINE and getting it's area - LISP


linuxap

Recommended Posts

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!

Link to comment
Share on other sites

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 by VVA
Link to comment
Share on other sites

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

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

AREA-3.jpg

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

dear sir

nice program thx for sharing

it's possible

Pline area into table

  1. Select pline (various layer for example area-1, area-2, area-e etc. )
  2. Add area center of pline (area in sq.mt. & sq.ft.)
  3. 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)
    )
 )
)

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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.

×
×
  • Create New...