Extract polyline length to Attributes (field)

Hello

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

I can not integrate my conditional function in my filter by select block (by ename)

 (vl-load-com)
(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))
 )

I try this, but not work

 (vl-load-com)
(while
 (setq e (entsel "\nnFilter  Selection by Entity name (Attribut LENGTH) : "))
(if e (setq js (ssget "_X" (list(cons 2 (cdr (assoc 2 (entget (car e)))))(cons 0 "INSERT")))))
  (setq dxf_cod (entget (ssname js 0)))
     (vlax-for x (setq js (setq acDoc
                                 (vla-get-activeselectionset
                                   (vla-get-activedocument
                                     (vlax-get-acad-object)
                                   )
                                 )
                          )
                 )
       (foreach att (vlax-invoke x 'getattributes)
         (if (/= "LENGTH" (vla-get-tagstring att))
           (progn
 (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))
 )
         )
         (princ "\nThis Block do not contain LENGTH tag"
      )
   )
 )
)
....

Where is my error ?

Hi tamariz,

I'm a little puzzled with your code...

Try to write a pseudo code, in simple words, explaining what you are trying to do.

Henrique

Hi Henrique,

The code in this post http://www.cadtutor.net/forum/showthread.php?90252-Extract-polyline-length-to-Attributes-(field)&p=617951&viewfull=1#post617951 only works if the block contains Length's Tag , I try (for my personal cultivation) to have an error message when I select another block "this block do not contains Length's Tag" with the function

(if (/= "LENGTH" (vla-get-tagstring att))

I should choose a code easier for my first lisp

Perhaps something like this

(if (and (setq hnd (car (entsel "\nnFilter  Selection by Entity name (Attribut LENGTH) : ")))
           (setq ent (entget hnd))
           (= (cdr (assoc 0 ent)) "INSERT")
           (= (cdr (assoc 66 ent)) 1)
           (setq b hnd)
           (progn
             (while (and
                      (setq b (entnext b))
                      (setq e (entget b))
                    )
               (if (and (= (cdr (assoc 0 e)) "ATTRIB")
                        (= (cdr (assoc 2 e)) "LENGTH")
                   )
                 (setq a T)
               )
             )
             a
           )
      )
 (progn
 (setq js (ssget "_X" (list (cons 0 "INSERT") (assoc 2 ent) (cons 66 1))))
 ;; do the rest of the code
 );; progn
 (princ "\nThis Block do not contain LENGTH tag")
 );; if

Henrique

thank you I will study it

In my previous post http://www.cadtutor.net/forum/showthread.php?90252-Extract-polyline-length-to-Attributes-(field)&p=618231&viewfull=1#post618231 I had it all wrong?

thank you I will study it

 

In my previous post http://www.cadtutor.net/forum/showthread.php?90252-Extract-polyline-length-to-Attributes-(field)&p=618231&viewfull=1#post618231 I had it all wrong?

I have a deadline to meet today, so later I'll post your code with some comments.

Henrique

Hi tamariz, sorry for the late reply.

'I had it all wrong?'

Your code:

you are setting the variable 'e' with the return from entsel function

(setq e (entsel "\nFilter  Selection by Entity name: "))

after the user select an object, you test for a valid 'e' and if true, make a selection set using as filters the object type "INSERT" and the return from 'dxf 2'.

If the object selected was an "INSERT" it will have a 'dxf 2' and it's name, but if user select a different type of object, there is no 'dxf 2' and the code will error...

In the filter you are not ensuring the "INSERT" have "ATTRIBUTES" (66 . 1)

(if e (setq js (ssget "_X" (list(cons 2 (cdr (assoc 2 (entget (car e)))))(cons 0 "INSERT")))))

you are set the 'dxf_cod' with the return from 'entget' the first selection set entity

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

If the user fail to select at the 'entsel' function, the code will continue until the 'ssname' funtion, then will error because there is no selection set.

you are removing all dotted pairs, except the dxf '0' and '2' from the dxf_cod, to use later in the code as 'ssget' filter list.

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

 )

When we write a code, we should take into account all possible errors, and validate all data.

The code lines I did post >> here , were just to demonstrate a possible way to select one entity, and test all conditions, testing a valid selection, an "INSERT", has attributes, has a "LENGTH" tag.

Probably, I would use something like this to write your test function

(if (and (princ "\nFilter Selection by Entity name (Attribut LENGTH) : ")
        (setq js (ssget "_+.:E:S" '((0 . "INSERT") (66 . 1))))
        (setq hnd (ssname js 0))
        (setq dxf_cod (entget hnd))
        (progn
          (while (and
                   (setq hnd (entnext hnd))
                   (setq e (entget hnd))
                 )
            (if (and (= (cdr (assoc 0 e)) "ATTRIB")
                     (= (cdr (assoc 2 e)) "LENGTH")
                )
              (setq a T)
            )
          )
          a
        )
        (setq dxf_cod (list '(0 . "INSERT") (assoc 2 dxf_cod) '(66 . 1)))
   )
 (progn
  ;; do the rest of the code
 );; progn
 (princ "\nThis Block do not contain LENGTH tag")
);; if

Henrique

Hi Henrique,

Thank you again for your remarks

You're welcome, tamariz

Henrique

Hi Guys,

I need your help in writing a LISP that perform the following functions:

1- Insert a pre-defined block (e.g. "Xtag") at the two extremities of each polyline in a given drawing;

2- Sequential numbering of the tag ref. "Tag", within the a/m block, in such a way that for a given polyline, the tagging number starts with for example "A12" fit should be "A13" for the other end and so on for all polylines in the drawing;

3- Measure the length of each polyline and insert the result (in mm) in form of a point block with two attributes: the 1st attribute with the combined tag of the two polylines extremities attributes (e.g. A12-A13) and the 2nd attribute consisting of the measured length in mm. This block point should be located around the middle of the polyline.

I am attaching reference drawing and the drawing block "Xtag" for your use.

I know that this lisp is not an easy one, but it would save an incredible amount of time in a project whihc submission is due in one week!

Thank you ,

Nasr

FG-CHW.dwg

XTag.dwg

Hi again,

If the above seems to be too bulky to achieve, maybe editing the following lisp in such a way to generates a block including two attributes, instead of a Mtext, to be located in the middle of the polyline. The first attribute should be a sequential tag (e.g. A11, A12, A13, etc.) where I am given the choice to choose the letter A, B, etc.

The second attribute should include the length of the polyline in mm.

The heights of the attributes text should be an input by the user.

thanks,

Nasr

(defun c:midlen ( / *error* ent fmt idx ins ocs par sel spc txt typ uxa )

   (setq fmt "%lu6") ;; Field Formatting

   (defun *error* ( msg )
       (LM:endundo (LM:acdoc))
       (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
           (princ (strcat "\nError: " msg))
       )
       (princ)
   )
   
   (if
       (setq sel
           (ssget
               (list
                  '(0 . "ARC,CIRCLE,LINE,*POLYLINE")
                  '(-4 . "<NOT")
                      '(-4 . "<AND")
                          '(0 . "POLYLINE")
                          '(-4 . "&")
                          '(70 . 80)
                      '(-4 . "AND>")
                  '(-4 . "NOT>")
                   (if (= 1 (getvar 'cvport))
                       (cons 410 (getvar 'ctab))
                      '(410 . "Model")
                   )
               )
           )
       )
       (progn
           (setq spc
               (vlax-get-property (LM:acdoc)
                   (if (= 1 (getvar 'cvport))
                       'paperspace
                       'modelspace
                   )
               )
           )
           (setq ocs (trans '(0.0 0.0 1.0) 1 0 t)
                 uxa (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
           )
           (LM:startundo (LM:acdoc))
           (repeat (setq idx (sslength sel))
               (setq ent (ssname sel (setq idx (1- idx)))
                     par (vlax-curve-getparamatdist ent (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2.0))
                     ins (vlax-curve-getpointatparam ent par)
                     typ (cdr (assoc 0 (entget ent)))
               )
               (setq txt
                   (vlax-invoke spc 'addmtext ins 0.0
                       (strcat
                           "%<\\AcObjProp Object(%<\\_ObjId " (LM:objectid (vlax-ename->vla-object ent)) ">%)."
                           (cond
                               (   (= "CIRCLE" typ) "Circumference")
                               (   (= "ARC"    typ) "ArcLength")
                               (   "Length"   )
                           )
                           " \\f \"" fmt "\">%"
                       )
                   )
               )
               (vla-put-backgroundfill  txt :vlax-true)
               (vla-put-attachmentpoint txt acattachmentpointmiddlecenter)
               (vla-put-insertionpoint  txt (vlax-3D-point ins))
               (vla-put-rotation txt (LM:readable (- (angle '(0.0 0.0 0.0) (trans (vlax-curve-getfirstderiv ent par) 0 ocs t)) uxa)))
           )
           (LM:endundo (LM:acdoc))
       )
   )
   (princ)
)

;; Readable  -  Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
   (   (lambda ( a )
           (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
               (LM:readable (+ a pi))
               a
           )
       )
       (rem (+ a pi pi) (+ pi pi))
   )
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
   (eval
       (list 'defun 'LM:objectid '( obj )
           (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
               (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                   (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                  '(LM:ename->objectid (vlax-vla-object->ename obj))
               )
              '(itoa (vla-get-objectid obj))
           )
       )
   )
   (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
   (LM:hex->decstr
       (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
             ent (substr ent (+ (vl-string-position 58 ent) 3))
       )
   )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
   (defun foo ( lst rtn )
       (if lst
           (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
           (apply 'strcat (mapcar 'itoa (reverse rtn)))
       )
   )
   (defun bar ( int lst )
       (if lst
           (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
               (cons (rem int 10) (bar (/ int 10) (cdr lst)))
           )
           (bar int '(0))
       )
   )
   (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
   (LM:endundo doc)
   (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
   (while (= 8 (logand 8 (getvar 'undoctl)))
       (vla-endundomark doc)
   )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
   (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
   (LM:acdoc)
)

(vl-load-com)
(princ
   (strcat
       "\n:: MidLen.lsp | Version 1.1 | \\U+00A9 Lee Mac "
       (menucmd "m=$(edtime,0,yyyy)")
       " www.lee-mac.com ::"
       "\n:: Type \"midlen\" to Invoke ::"
   )
)
(princ)