Jump to content

How to create texts to "name" closed polylines and export "names" and area to excel


scremin

Recommended Posts

Hello everyone, I am a brand-new member of this forum and I would really appreciate some help. I'm in need of a routine do to the following:

--Add text to represent a closed polyline label.

--Then the routine should take polyline area and export the Label and the area data to an Excel file, like showed in the image.

imagemxqb.png

imagemxqb.png

 

I really need some help, because this repetitive job is killing me. I have like 900 polylines to give a Label and extract the area.

 

Thanks

Link to comment
Share on other sites

  • 6 months later...
  • Replies 20
  • Created
  • Last Reply

Top Posters In This Topic

  • Costinbos77

    5

  • fixo

    4

  • mo70mo70

    4

  • Stephen316

    2

Top Posters In This Topic

Posted Images

The program searches all polylines on selected layer .

 

For starters try this:

 

(defun c:aa () ; V : 13.01.2013 ; 12.01.2013 .
(setvar "cmdecho" 0)
(setq osm (getvar "osmode") )
(setvar "osmode" 0)


(if (setq ht 0.2  lsel 0  ob (car (entsel "\n   Select  an  Object  for  LAYER   :  < Pick >  :  ")) )
 (progn
  (command "zoom" "e")
  (setq str (cdr (assoc 8 (entget ob)) )  sel (ssget "X" (list '(0 . "LWPOLYLINE,POLYLINE") (cons 8 str)) )  ) ;
  (if sel
    (progn
     (command "zoom" "o" sel "") (sssetfirst nil sel) ; Selectare Vizualizare Selectie !
     (if (/= (getstring (strcat "\n   SELECTED objects on LAYER  :  " str " ;\n   Any  =  NO ;   Enter  =  OK  :  ")) "") (setq sel nil))
     (sssetfirst sel) ; DeSelectare Vizualizare Selectie !
  ) ) ; if sel

  (if sel
   (progn  (or (vl-load-com))
    (setq lsel (sslength sel)  cale (strcat (getvar "dwgprefix") (getvar "dwgname") " - " (rtos (getvar "cdate") 2 6) ".csv")
   f (open cale "w")  i 0)
    (write-line "\nLabel, Area\n-------------------------------" f)
    (while (< i lsel)
     (setq nobi (ssname sel i)  nobv (vlax-ename->vla-object nobi)  ar (vla-get-Area nobv)  ars (rtos ar 2 5)  i (1+ i)
    lc (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates nobv)))  llc (length lc)  n (/ llc 2.)  j 0  sx 0  sy 0)

     (while (< j llc) (setq sx (+ (nth j lc) sx)  j (1+ j)  sy (+ (nth j lc) sy)  j (1+ j) )  ) ; wh
     (command "text" "m" (list (/ sx n) (/ sy n) 0) ht 0 (strcat "\n   Area  " (itoa i) " = " ars))
     (princ (strcat "\n   Area  " (itoa i) "  :  " ars))
     (write-line (strcat "Area  " (itoa i) ", " ars) f)
    ) ; wh <
    (if (and cale (findfile cale)) (close f))
  ) ) ; if sel
)) ; if ob
(setvar "osmode" osm)
(setvar "cmdecho" 1)
(princ (strcat "\n   Height  of  Texts  :  " (rtos ht 2 5) 
                   "\n   Number  of  Areas  :  " (itoa lsel) "  ."))
(princ "\n   END  !")(princ)
) ; end defun c:aa

 

The program does not write directly in Excel, but you can open the results file .CSV with Excel . CSV file is saved to DWG path.

To write something in Excel, you need a function to open and write to Excel and is more complex.

 

Simple and to the point. Processes only selected layer. NOT check different :

- If the polyline has 2 vertecsi and the area is 0 ;

- Do not check if the polyline is closed ;

- height text ;

- Start writing that labeling ;

- Etc.

Lisp was written in about 30 minutes.

Edited by Costinbos77
Link to comment
Share on other sites

gS7, It is very hard as usual.

 

I thought a simple variant in a short time, to help scremin to process the 900 polylines quickly. As you need other facilities, they added.

Edited by Costinbos77
Link to comment
Share on other sites

Here is my 2 cents

 
(defun C:DXLW (/ acsp adoc ang ar area centpoint col fname inspt n plent plineobj regionobj row
sset thgt tot tst tsz txtobj xldata xlapp xlbook xlbooks xlcells xlsheet xlsheets)
(vl-load-com)
;;;local defun
(defun setcelltext(cells row column value)
(vl-catch-all-apply
'vlax-put-property
(list cells 'Item row column
(vlax-make-variant
(vl-princ-to-string value) ))
)
;;----------------------------- main part ---------------------;; 
(or adoc
(setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(or acsp
(setq acsp (vla-get-block
(vla-get-activelayout adoc))))
(vla-startundomark adoc)
(setq tsz (getvar "textsize"))
(setq tst (getvar "textstyle"))
;; set text style you need:
(setvar "textstyle" "Standard")
;; set text size
(setq thgt (getdist "\nText Height: "))
(if (not thgt)(setq thgt (getvar "dimtxt")))
(setvar "textsize" thgt)
(princ "\n\t---\tSelect contours\t---")
(setq sset
(ssget 
'(
(0 . "LWPOLYLINE")
(8 . "ANNO-AREA"); <-- set layer of polygons
(-4 . "<OR")
(70 . 1);flag for closed curve, linetype generation disabled
(70 . 129);flag for closed curve, linetype generation enabled
(-4 . "OR>")
)
)
)
(setq n 1 tot 0.0)
(while (setq plent (ssname sset 0))
(setq plineObj (vlax-ename->vla-object plent)
ar (vla-get-area plineObj)
tot (+ tot ar)
area (rtos ar 2 2)
)
(setq regionObj (car (vlax-invoke acsp 'addregion (list plineObj))))
(setq centPoint (trans (vlax-get regionObj 'centroid) 1 0)) 

(setq inspt (vlax-3d-point centPoint))
(setq txtobj (vla-addtext acsp (strcat "Label-"(itoa n)) inspt thgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vla-put-textalignmentpoint txtobj inspt)
(vla-put-insertionpoint txtobj inspt)
(setq xldata (append xldata (list (list (strcat "Label-"(itoa n)) area))))
(vl-catch-all-apply '(lambda()
(progn (vla-delete regionObj)
(vlax-release-object regionObj)
)))
(setq n (1+ n))
(ssdel plent sset)
)
(print xldata)
(princ "\nTotal: ")
(print tot)
;;------------------------ Excel part ----------------------------;;
(setq xlapp (vlax-get-or-create-object "Excel.Application")
xlbooks (vlax-get-property xlapp 'Workbooks)
xlbook (vlax-invoke-method xlbooks 'Add)
xlsheets (vlax-get-property xlbook 'Sheets)
xlsheet (vlax-get-property xlsheets 'Item 1)
xlcells (vlax-get-property xlsheet 'Cells)
)


(vla-put-visible xlapp :vlax-true)

(vla-put-name xlsheet "Plan1")

(setq row 1)


(foreach label xldata
(setq col 1)
(foreach item label
(setcelltext xlcells row col item)
(setq col (1+ col)
)
)
(setq row (1+ row)
)
)
(setcelltext xlcells row 1 "Total:")

(setcelltext xlcells row 2 (rtos tot 2 2));<-- precision 2 decimal

(vlax-invoke-method
(vlax-get-property xlsheet 'Columns)
'AutoFit)

(setq fname (strcat (getvar "dwgprefix")(vl-string-right-trim ".dwg" (getvar "dwgname")) ".xls"))
(vlax-invoke-method
xlbook
'SaveAs
fname 
nil
nil
nil
:vlax-false
:vlax-false
1
2
)
(vlax-invoke-method
xlbook 'Close)
(gc)
(vlax-invoke-method
xlapp 'Quit)
(mapcar '(lambda (x)
(vl-catch-all-apply
'(lambda ()
(vlax-release-object x)
)
)
)
(list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
)
(setq xlapp nil)
(gc)(gc)
(alert (strcat "File saved as:\n" fname))


(setvar "textsize" tsz)
(setvar "textstyle" tst)
(vla-endundomark adoc)
(princ)
)
(princ "\n\t---\tStart command with DXLW ...\t---")
(prin1)
(or (vl-load-com)(princ))

Link to comment
Share on other sites

Congratulations Fixo!

Your code is just amazing.

 

Costinbos77 said:

To write something in Excel, you need a function to open and write to Excel and is more complex.

 

I totally agree. But here in this excellent forum there are people who doing things unbelievable.

 

It's really impressive. Every day when I come in this forum I'm surprised.

 

Thanks to all, gurus!

Link to comment
Share on other sites

Its very good but if we can extract legth for each line of that poly line it will be very good thing

 

Post the screenshot of Excel file, I didn't understand

how the values will be stored row by row

Link to comment
Share on other sites

I completed the Lisp with calculation of distances .

1. These distances should to appear in dwg? If yes, on a different layer at the surface? Be text or "dimension"?

2. The texts have a specific height?

 

 

(defun C:aa (/ ar ars cale d f ht i j k lc lis llis llc lsel p1 p2 pm pi2 3pi2 2pi nobi nobv ob sel str sx sy td u x y )
(setvar "cmdecho" 0) ; V : 14 . 01 . 2013 , 13 . 01 . 2013 , 12 . 01 . 2013 . C:PreSup
(setq osm (getvar "osmode") )
(setvar "osmode" 0)

(if (setq ht 0.2  lsel 0  ob (car (entsel "\n   C:PreSup  :  V  :  13 . 01 . 2013  ;\n   Select  an  Object  for  LAYER   :  < Pick >  :  ")) )
 (progn
  (command "zoom" "e")
  (setq str (cdr (assoc 8 (entget ob)) )  ) ;_ end of setq
  (princ (strcat "\n   Select  Objects  for  LAYER   :  " str "  ;  \n   < Pick >  ;  Enter  =  Whole  Layer  :  "))
  (if (not (setq sel (ssget (list '(0 . "LWPOLYLINE,POLYLINE") (cons 8 str)) ))  )
   (setq sel (ssget "X" (list '(0 . "LWPOLYLINE,POLYLINE") (cons 8 str)) )  )  ) ;_ end of if not

  (if sel
    (progn
     (command "zoom" "o" sel "") (sssetfirst nil sel) ; Selectare Vizualizare Selectie !
     (if (/= (getstring (strcat "\n   SELECTED objects on LAYER  :  " str " ;\n   Any  =  NO ;   Enter  =  OK  :  ")) "") (setq sel nil))
     (sssetfirst sel) ; DeSelectare Vizualizare Selectie !
  ) ) ; if sel

  (if sel
   (progn  (or (vl-load-com))
    (command "_layer" "m" "Area Text" "c" 1 "Area Text" "")
    (setq lsel (sslength sel)  cale (strcat (getvar "dwgprefix") (getvar "dwgname") " - " (rtos (getvar "cdate") 2 6) ".csv")
   f (open cale "w")  pi2 (/ pi 2)  3pi2 (* pi2 3)  2pi (* pi 2)  i 0)
    (write-line "\nLabel, Area,D 1,D 2, D 3,D 4,D 5,D 6, D 7\n-------------------------------" f)
    (while (< i lsel)
     (setq nobi (ssname sel i)  nobv (vlax-ename->vla-object nobi)  ar (vla-get-Area nobv)  i (1+ i) )
     (if (> ar 0)
      (progn
(setq lc (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates nobv)))
      llc (length lc)  n (/ llc 2.)  ars (rtos ar 2 5)  j 0  sx 0  sy 0  lis nil)
       (while (< j llc) (setq x (nth j lc)  sx (+ x sx)  j (1+ j)  y (nth j lc)  sy (+ y sy)  j (1+ j)  lis (cons (list x y) lis) )  ) ; wh
       (setq llis (length lis)  k 0  td "")
       (while (< k llis)
        (setq p1 (nth k lis)  k (1+ k)  p2 (nth (if (= k llis) 0 k) lis) )
        (setq d (distance p1 p2)  u (angle p1 p2)  td (strcat td ", " (rtos d 2 5))  pm (mapcar '/ (mapcar '+ p1 p2) '(2. 2.) ) )
 (if (and (> u pi2) (< u 3pi2)) (setq u (+ u pi)) )
 (if (> u 2pi) (setq u (- u 2pi)) )
        (entmake (list '(0 . "TEXT") (cons 8 "Area Text") '(10 0 0 0) (cons 40 ht) (cons 1 (strcat (rtos d 2 3) " m")) ;'(7 . "Arial")
      (cons 50 u) '(72 . 4) (append '(11) pm) ) ) ;_ end of entmake
;;;         (command "text" "m" pm ht u (strcat (rtos d 2 3) ))
       ) ; wh (< k llis)

       (command "text" "m" (list (/ sx n) (/ sy n) 0) ht 0 (strcat "\n   Area  " (itoa i) " = " ars))
       (write-line (strcat "Area  " (itoa i) ", " ars td) f)
       (princ (strcat "\n   Area  " (itoa i) "  :  " ars ))
      )
     ) ; if (> ar 0)

    ) ; wh <
    (if (and cale (findfile cale)) (close f))
  ) ) ; if sel
)) ; if ob
(setvar "osmode" osm)
(setvar "clayer" "0")
(setvar "cmdecho" 1)
(princ (strcat "\n   Height of  Texts  :  " (rtos ht 2 5)   
                    "\n   Number  of  Areas  :  " (itoa lsel) "  ."))
(princ "\n   END  !")
(princ)
)

Edited by Costinbos77
Link to comment
Share on other sites

[ATTACH=CONFIG]39579[/ATTACH]

fixo i hope that attached can be clear

Sorry your piccy is bad

How to write X,Y coordinates in this cells?

Show me please, what you want to add in every cell

 

Without your good screen shot try this, very limited tested

 
(defun C:ARXL (/ acsp adoc ar area centpoint col epar fname inspt leg leg_list n perim plent pline_data plineobj regionobj
row spar sset thgt tot tst tsz txtobj xlapp xlbook xlbooks xlcells xldata xlsheet xlsheets)
(vl-load-com)
;;;local defun
(defun setcelltext(cells row column value)
(vl-catch-all-apply
'vlax-put-property
(list cells 'Item row column
(vlax-make-variant
(vl-princ-to-string value) ))
)
;;----------------------------- main part ---------------------;; 
(or adoc
(setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(or acsp
(setq acsp (vla-get-block
(vla-get-activelayout adoc))))
(vla-startundomark adoc)
(setq tsz (getvar "textsize"))
(setq tst (getvar "textstyle"))
;; set text style you need:
(setvar "textstyle" "Standard")
;; set text size
(setq thgt (getdist "\nText Height: "))
(if (not thgt)(setq thgt (getvar "dimtxt")))
(setvar "textsize" thgt)
(princ "\n\t---\tSelect contours\t---")
(setq sset
(ssget 
'(
(0 . "LWPOLYLINE")
(8 . "ANNO-AREA"); <-- set layer of polygons
(-4 . "<OR")
(70 . 1);flag for closed curve, linetype generation disabled
(70 . 129);flag for closed curve, linetype generation enabled
(-4 . "OR>")
)
)
)
(setq n 1 tot 0.0)
(while (setq plent (ssname sset 0))
(setq leg_list nil)
(setq plineObj (vlax-ename->vla-object plent))
(setq spar (vlax-curve-getstartparam plineObj)
epar (vlax-curve-getendparam plineObj))
(while (< spar epar)
(setq leg (- (vlax-curve-getdistatparam plineObj(+ spar 1))(vlax-curve-getdistatparam plineObj spar))
leg_list (cons (rtos leg 2 2) leg_list))
(setq spar (1+ spar)))
(setq leg_list (reverse leg_list))
(setq ar (vla-get-area plineObj)
perim (rtos (vla-get-length plineObj) 2 2)
tot (+ tot ar)
area (rtos ar 2 2)
)
(setq regionObj (car (vlax-invoke acsp 'addregion (list plineObj))))
(setq centPoint (trans (vlax-get regionObj 'centroid) 1 0)) 

(setq inspt (vlax-3d-point centPoint))
(setq txtobj (vla-addtext acsp (strcat "Label-"(itoa n)) inspt thgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vla-put-textalignmentpoint txtobj inspt)
(vla-put-insertionpoint txtobj inspt)
(setq pline_data nil)
(setq pline_data (append pline_data (append (append (list (strcat "Label-"(itoa n)) area)(list perim) leg_list))))
(setq xldata (append xldata (list pline_data)))
(vl-catch-all-apply '(lambda()
(progn (vla-delete regionObj)
(vlax-release-object regionObj)
)))
(setq n (1+ n))
(ssdel plent sset)
)
(print xldata)
(princ "\nTotal: ")
(print tot)
;;------------------------ Excel part ----------------------------;;
(setq xlapp (vlax-get-or-create-object "Excel.Application")
xlbooks (vlax-get-property xlapp 'Workbooks)
xlbook (vlax-invoke-method xlbooks 'Add)
xlsheets (vlax-get-property xlbook 'Sheets)
xlsheet (vlax-get-property xlsheets 'Item 1)
xlcells (vlax-get-property xlsheet 'Cells)
)


(vla-put-visible xlapp :vlax-true)

(vla-put-name xlsheet "Plan1")

(setq row 1)


(foreach label xldata
(setq col 1)
(foreach item label
(setcelltext xlcells row col item)
(setq col (1+ col)
)
)
(setq row (1+ row)
)
)
(setcelltext xlcells row 1 "Total:")

(setcelltext xlcells row 2 (rtos tot 2 2));<-- precision 2 decimal

(vlax-invoke-method
(vlax-get-property xlsheet 'Columns)
'AutoFit)

(setq fname (strcat (getvar "dwgprefix")(vl-string-right-trim ".dwg" (getvar "dwgname")) ".xls"))
(vlax-invoke-method
xlbook
'SaveAs
fname 
nil
nil
nil
:vlax-false
:vlax-false
1
2
)
(vlax-invoke-method
xlbook 'Close)
(gc)
(vlax-invoke-method
xlapp 'Quit)
(mapcar '(lambda (x)
(vl-catch-all-apply
'(lambda ()
(vlax-release-object x)
)
)
)
(list xlcells xlsheet xlsheets xlbook xlbooks xlapp)
)
(setq xlapp nil)
(gc)(gc)
(alert (strcat "File saved as:\n" fname))


(setvar "textsize" tsz)
(setvar "textstyle" tst)
(vla-endundomark adoc)
(princ)
)
(princ "\n\t---\tStart command with ARXL ...\t---")
(prin1)
(or (vl-load-com)(princ))

Edited by fixo
Link to comment
Share on other sites

tank you fixo but This code does not select any objects!!!!

when i drag and try to select objects , what will be displayed in command line:Select objects: 0 found!!!

Link to comment
Share on other sites

  • 2 weeks later...
  • 4 months later...

icon1.gif

 

How to create texts to "name" closed polylines and export "names" and area to active cell excel iam mohmed fawzy

 

1- select active cell

2-slesct poly lines

Link to comment
Share on other sites

  • 1 year later...

Dear Costinbos77,

 

The code that you have provided was very useful, but can i ask you for one more favour?? The code now extracts the area of polylines and adds a area label and saves in .csv format. Can you please modify the code to print the area labels in drawing itself?? without area labels in drawing it becomes difficult to locate them, in my case i have close to 250 areas to locate.

 

Thanks in advance

Stephen

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