Extract polyline length to Attributes (field)

Hello; I am looking for a LISP allows selecting multiple polylines to extract their lengths to the attributes tag ( "length" ) blocks as fields ,

knowing that at each end of the polyline is the block in question ( where is the attribute tag). I found a LISP Lee Mac but it does not match my expectations because I have to select one by one each string and each attribute.

(defun c:Len2Fld ( / *error* tables doc spc p s q ExitFlag ) 
(vl-load-com)
     (while
 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (setq tables (LM:ss->vla (ssget "_X" '((0 . "ACAD_TABLE")))))

 (LM:ActiveSpace 'doc 'spc)   

 (cond
   (
     (setq p
       (LM:Selectif
         (lambda ( x )
           (vlax-property-available-p
             (vlax-ename->vla-object x) 'Length
           )
         )
         "\nMétré longeur, Selectionner cable: " nil
       )
     )
     (setq s
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
         (LM:GetObjectID doc (vlax-ename->vla-object p)) ">%).Length \\f \"%lu6\">%"
       )
     )         
     (while
       (progn
         (or ExitFlag
           (progn
             (initget "Point")
             (setq p (nentsel "\nSelect Text, MText or Attribute for Result [Point] <Exit> : "))
           )
         )
        
         (cond
           (
             ExitFlag nil
           )
           (
             (vl-consp p)
           
             (if (wcmatch (cdr (assoc 0 (entget (car p)))) "ATTRIB,*TEXT")
               (vla-put-TextString (vlax-ename->vla-object (car p)) s)
               (princ "\n** Object Must be Text, MText or Attribute **")
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)
)  

(defun LM:ActiveSpace ( *doc *spc )
 (set *spc
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (set *doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true (vla-get-MSpace (eval *doc)))
     )
     (vla-get-ModelSpace (eval *doc))
     (vla-get-PaperSpace (eval *doc))
   )
 )
)

(defun LM:Selectif ( foo str nest / e )
   (while
   (progn
     (setq e (car ((if nest nentsel entsel) str)))
     
     (cond
       (
         (eq 'ENAME (type e))

         (if (not (foo e)) (princ "\n** Invalid Object Selected **"))
       )
     )
   )
 )
 e
)


(defun LM:GetObjectID ( doc obj )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)


(defun LM:ss->vla ( ss )
  (if ss
   (
     (lambda ( i / e l )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq l (cons (vlax-ename->vla-object e) l))
       )
       l
     )
     -1
   )
 )
)

I would like to reduce the number operations , any help would be appreciated.

Here's the result I would like to have

Exemple dwg

Cablage VDI 3.dwg

Thank you in advance (sorry for my English )

Cablage VDI 2.dwg

Hello tamariz, and welcome to CADTutor!

If possible post a sample dwg with a few polylines and a few blocks to process.

Henrique

Thanks!

I added dwg for example in my previous post

Select the magenta LwPolylines...

(vl-load-com)
(defun c:demo (/ attlst blk doc en_pt obj ss ss1 ss2 st_pt)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           st_pt (vlax-curve-getStartPoint obj)
           en_pt (vlax-curve-getEndPoint obj)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "RJ45CAT6") (66 . 1))
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "RJ45CAT6") (66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LENGTH")
             (vla-put-TextString
               a
               (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:GetObjectID doc obj)
                       ">%).Length \\f \"%lu6\">%"
               )
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)


(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

Henrique

Amazing! Thanks a lot

The lisp works fine

I just added 2 commands because I have a project where my UCS is different of World

(vl-load-com)
(defun c:demo (/ attlst blk doc en_pt obj ss ss1 ss2 st_pt)
 (command "_.ucs" "_world")
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           st_pt (vlax-curve-getStartPoint obj)
           en_pt (vlax-curve-getEndPoint obj)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "etiquetteVDI") (66 . 1))
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "etiquetteVDI") (66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LONGUEUR")
             (vla-put-TextString
               a
               (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:GetObjectID doc obj)
                       ">%).Length \\f \"%lu6\">%"
               )
             )
           )
         )
       )
     )
   )
 )
 (command "UCS" "P")
 (vla-regen doc AcActiveViewport)
 (princ)
)


(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

Just wonder , why you are asking for a program since that you have one as shown in your video in the first post !

Just wonder , why you are asking for a program since that you have one as shown in your video in the first post !

it's just a video editing, I cut the sequence where I populates (manually) the fields

it was to add more understanding to my request (my english is poor)

one more question :

how to modify the lisp to replace fields with simple texts ?

I'm writing a lisp with 2 choices (field and text)

Perhaps something like this

(vl-load-com)
(defun c:demo (/ ans attlst blk doc en_pt obj ss ss1 ss2 st_pt)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
          (not (initget 1 "Attribute Text"))
          (setq ans (getkword "\nEnter an option [Attribute/Text]: "))
     )
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           str   (rtos (vla-get-Length obj) 2 2)
           st_pt (trans (vlax-curve-getStartPoint obj) 0 1)
           en_pt (trans (vlax-curve-getEndPoint obj) 0 1)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT")
                        (2 . "etiquetteVDI")
                        (66 . 1)
                       )
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT")
                        (2 . "etiquetteVDI")
                        (66 . 1)
                       )
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LENGTH")
             (vla-put-TextString
               a
               (if (= ans "Attribute")
                 (strcat "%<[url="file://\\AcObjProp"]\\AcObjProp[/url] Object(%<[url="file://\\_ObjId"]\\_ObjId[/url] "
                         (LM:GetObjectID doc obj)
                         ">%).Length [url="file://\\f"]\\f[/url] \"%lu6\">%"
                 )
                 str
               )
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)

(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

Henrique

Thanks,

I have an error

error: too many arguments: (IF (AND (SETQ SS (SSGET (QUOTE ((0 . "LWPOLYLINE"))))) (NOT (INITGET 1 "Attribute Text")) (SETQ ANS (GETKWORD "\nEnter an option [Attribute/Text]: "))) (REPEAT (SETQ I (SSLENGTH SS)) (SETQ OBJ (vlax-ename->vla-object (SSNAME SS (SETQ I (1- I)))) STR (RTOS (vla-get-Length OBJ) 2 2) ST_PT (TRANS (vlax-curve-getStartPoint OBJ) 0 1) EN_PT (TRANS (vlax-curve-getEndPoint OBJ) 0 1)) (COMMAND "_.zoom" "_C" ST_PT "") (SETQ SS1 (SSGET "_C" (POLAR ST_PT (* 0.25 PI) 0.1) (POLAR ST_PT (* 1.25 PI) 0.1) (QUOTE ((0 . "INSERT") (2 . "etiquetteVDI"))) (66 . 1)))) (COMMAND "_.zoom" "_C" EN_PT "") (SETQ SS2 (SSGET "_C" (POLAR EN_PT (* 0.25 PI) 0.1) (POLAR EN_PT (* 1.25 PI) 0.1) (QUOTE ((0 . "INSERT") (2 . "etiquetteVDI"))) (66 . 1))))

I will try to look at it

Thanks,

I have an error

error: too many arguments: ...

Sorry, my bad...

Code in msg#10 already reviewed.

Should work in WCS or UCS.

Henrique

Nice job !

Nice job !

Glad I could help

Henrique

I finish my lisp but i have a problem (an error)

I would like replace the block name by the entity name of the previous block selection in this filter (if my blockname is different of "etiquetteVDI")

But it is possible?

                      ('(0 . "INSERT")
                        (cons -2 dxf_cod)
                        '(66 . 1)
                       )

definition of the value "dxf_cod"

(setq dxf_cod (entget (ssname js 0)))

Here ensemble lisp code FIXED

(defun l-coor2l-pt (lst flag / )
 (if lst
   (cons
     (list
       (car lst)
       (cadr lst)
       (if flag
         (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
         (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
       )
     )
     (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
   )
 )
)
(defun c:CABLECDC2 ( / js dxf_cod mod_sel n lremov ename l_pt l_pr key js_cl obj_vlax pr lst_pt pt pt_cl e ans attlst blk doc en_pt obj ss ss1 ss2 st_pt)
(setq e (entsel "\nFilter  Selection by Entity name: "))
(if e (setq js (ssget "_X" (list(cons 2 (cdr (assoc 2 (entget (car e)))))(cons 0 "INSERT")))))
 (vl-load-com)
 (setq dxf_cod (entget (ssname js 0)))
 (foreach m (foreach n dxf_cod (if (not (member (car n) '(0 2 ))) (setq lremov (cons (car n) lremov))))
   (setq dxf_cod (vl-remove (assoc m dxf_cod) dxf_cod))
 )
 (initget "Unique Tout Manuel _Single All Manual")
 (if (eq (setq mod_sel (getkword "\nMode de sélection filtrée, choix [unique/Tout/Manuel]<Manuel>: ")) "Single")
   (setq n -1)
   (if (eq mod_sel "All")
       (setq js (ssget "_X" dxf_cod) n -1)
       (setq js (ssget dxf_cod) n -1)
   )
 )
 (repeat (sslength js)
   (setq ename (vlax-ename->vla-object (ssname js (setq n (1+ n)))))
   (setq l_pr (list 'StartPoint 'EndPoint 'Center 'InsertionPoint 'Coordinates 'FitPoints))
   (foreach n l_pr
     (if (vlax-property-available-p ename n)
       (setq l_pt
         (if (or (eq n 'Coordinates) (eq n 'FitPoints))
           (append
             (if (eq (vla-get-ObjectName ename) "AcDbPolyline")
               (l-coor2l-pt (vlax-get ename n) nil)
               (if (and (eq n 'FitPoints) (zerop (vlax-get ename 'FitTolerance)))
                 (l-coor2l-pt (vlax-get ename 'ControlPoints) T)
                 (l-coor2l-pt (vlax-get ename n) T)
               )
             )
             l_pt
           )
           (cons (vlax-get ename n) l_pt)
         )
       )
     )
   )
 )
 (cond
   (l_pt
     (while (and (setq key (grread T 4 0)) (/= (car key) 3))
       (redraw)
       (cond
         ((eq (car key) 5)
           (foreach n l_pt
             (grdraw (trans n 0 1) (cadr key) 3)
           )
         )
       )
     )
     (if (eq (car key) 3)
       (progn
         (princ "\nSelect polyline (cable tray): ")
         (while (not (setq js_cl (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))))))
         (setq obj_vlax (vlax-ename->vla-object (ssname js_cl 0)) pr -1 lst_pt nil)
         (repeat (if (zerop (vlax-get obj_vlax 'Closed)) (1+ (fix (vlax-curve-getEndParam obj_vlax))) (fix (vlax-curve-getEndParam obj_vlax)))
           (setq
             pt (vlax-curve-GetPointAtParam obj_vlax (setq pr (1+ pr)))
             lst_pt (cons pt lst_pt)
           )
         )
         (if (< (distance (car lst_pt) (trans (cadr key) 1 0)) (distance (last lst_pt) (trans (cadr key) 1 0)))
           (setq lst_pt (reverse lst_pt))
         )
         (foreach n l_pt
           (setq pt_cl (vlax-curve-getClosestPointTo obj_vlax n))
           (command "_.pline" "_none" (trans n 0 1) "_none" (trans pt_cl 0 1))
           (foreach el lst_pt
             (if (<= (distance el (trans (cadr key) 1 0)) (distance pt_cl (trans (cadr key) 1 0)))
               (command "_none" (trans el 0 1))
             )
           )
           (command "_none" (cadr key) "")
         )
       )
     )
     (redraw)
   )
 )
(vl-load-com)
(command "_.ucs" "_world")
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (and (setq ss (ssget '((0 . "LWPOLYLINE"))))
          (not (initget 1 "Attribute Text"))
          (setq ans (getkword "\nEnter an option [Attribute/Text]: "))
     )
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           str   (rtos (vla-get-Length obj) 2 2)
           st_pt (trans (vlax-curve-getStartPoint obj) 0 1)
           en_pt (trans (vlax-curve-getEndPoint obj) 0 1)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      (list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))
                  )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      (list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LENGTH")
             (vla-put-TextString
               a
               (if (= ans "Attribute")
                 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                         (LM:GetObjectID doc obj)
                         ">%).Length \\f \"%lu6\">%"
                 )
                 str
               )
             )
           )
         )
       )
     )
   )
 )
 (command "UCS" "P")
 (vla-regen doc AcActiveViewport)
 (princ)
)

(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

Hi tamariz,

if your block is not dynamic,

(cons 2 dxf_cod)

will do the trick.

Henrique

Hi tamariz,

 

if your block is not dynamic,

(cons 2 dxf_cod)

will do the trick.

 

Henrique

I try this, but i have an error: bad function: (0 . "INSERT")

I think the code 2 is for a Blockname but (setq dxf_cod (entget (ssname js 0))) return an entity name?

Any idea?

My block is not dynamic.

Happy New Year and good health to all

Try

(list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))

EDIT: ename is unique, with the entity name you don't need to select, just change the atribute... (I'm don't understand what you are trying to do)

EDIT 1:with

(setq dxf_cod (entget (ssname js 0))) 

you'll get a list with all the entity definition data, with

(cdr (assoc -1 dxf_cod))

you'll get the entity name...

HTH

Henrique

Try

(list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1))

Works fine !

EDIT: ename is unique, with the entity name you don't need to select, just change the atribute... (I'm don't understand what you are trying to do)

EDIT 1:with

(setq dxf_cod (entget (ssname js 0))) 

you'll get a list with all the entity definition data, with

(cdr (assoc -1 dxf_cod))

you'll get the entity name...

 

HTH

Henrique

thank you for this information and your patience

I am a beginner and this is my first lisp

I fixed the code in my previous post http://www.cadtutor.net/forum/showthread.php?90252-Extract-polyline-length-to-Attributes-(field)&p=617951&viewfull=1#post617951

Works fine !

thank you for this information and your patience

I am a beginner and this is my first lisp

I fixed the code in my previous post http://www.cadtutor.net/forum/showthread.php?90252-Extract-polyline-length-to-Attributes-(field)&p=617951&viewfull=1#post617951

You're welcome, tamariz!

Glad you got a solution!

We all had to write our first code...

Henrique