Amending Some Old Code to Read Attribute

[abra-CAD-abra]

All,

 

I am trying to amend the following code to read the attribute value with tag name "OBJECT_ID". Then, write the values to the variable blklist:

 

;http://www.cadtutor.net/forum/showthread.php?31122-Block-Distance-From-Nearest-Point-on-a-Polyline/page5
;Original Code By Lee Mac
(defun c:pdis (/    varlist     oldvars  cCurve   nlist    sAng     cBlock   txtpnt   index    ent
          dPt1    dPt2     blkDist  blkDist2 blkDist3 blklist  txt      dCurve   lPt1    rl
         )
   (defun makelay (x)
   (if (not (tblsearch "Layer" x))
       (progn
       (setvar "cmdecho" 0)
       (command "-layer" "m" x "")
       (setvar "cmdecho" 1)
       )
   )
   )
   (defun Make_Text (txt_pt txt_val)
   (entmake
       (list '(0 . "TEXT")
         '(8 . "TEXT")
         (cons 10 txt_pt)
         (cons 40 2.5)
         (cons 1 txt_val)
         '(50 . 0.0)
         '(7 . "STANDARD")
         '(71 . 0)
         '(72 . 0)
         '(73 . 0)
       ) 
   )
   )
   (defun massoc (key alist / x)
   (foreach x alist
       (if    (eq key (car x))
       (setq nlist (cons (cdr x) nlist))
       ) ;end if
   ) ;end foreach
   (setq nlist (reverse nlist))
   ) ;end defun
   (setq varlist (list "CMDECHO" "CLAYER")
     oldvars (mapcar 'getvar varlist)
   ) ;_  end setq
   (setvar "cmdecho" 0)
   (vl-load-com)
   (if
   (and
       (setq cCurve (car (entsel "\nSelect Curve to Measure > ")))
       (member (cdr (assoc 0 (entget cCurve)))
           '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE" "ARC" "CIRCLE" "ELLIPSE")
       ) ;_  end member
   ) ; end and
      (progn
          (massoc 10 (entget cCurve))
          (setq sAng (angle (nth 0 nlist)
                (nth 1 nlist)
             ) ;_  end angle
          ) ;_  end setq
          (while
          (and
              (setq cBlock (ssget '((0 . "INSERT")(66 . 1))))       ;abra-cad-abra                          
              (setq txtpnt (getpoint "\nSelect Point for Table > "))
          ) ;_  end and
             (makelay "TEXT")
             (setq index   (1- (sslength cBlock))
               blklist "\n"
               txt        1
             ) ;_  end setq
             (command "_offset" "0.01" cCurve (polar (nth 0 nlist) (- sAng (/ pi 2)) 0.01) "")
             (setq dCurve (entlast))
             (while (not (minusp index))
             (setq    ent     (entget (ssname cBlock index))
               dPt1     (cdr (assoc 10 ent))
               dPt2     (vlax-curve-getClosestPointTo cCurve dPt1)
               blkDist2 (distance dPt1 dPt2)
               blkDist     (expt (+ (expt (- (car dPt1) (car dPt2)) 2)
                         (expt (- (cadr dPt1) (cadr dPt2)) 2)
                          ) ;_  end +
                          0.5
                    ) ;_  end exp

   tag "OBJECT_ID"                                                    ;abra-cad-abra 
   att (LM:GetAttributeValue (vlax-ename->vla-object cBlock) tag)     ;abra-cad-abra 
   txt_val (cons (vla-get-TextString att) txt_val)        ;abra-cad-abra  

             ) ;_  end setq

    (setq lPt1 (vlax-curve-getClosestPointTo dCurve dPt1)
               blkDist3 (distance dPt1 lPt1)
             ) ;_  end setq

             (if (< blkDist3 blkDist2)
                 (setq rl "RHS")
                 (setq rl "LHS")
             ) ;_  end if

             (setq blklist (strcat      
     txt_val        ;abra-cad-abra 
              " "            ;abra-cad-abra
                       (rtos (car dPt1) 2 5)
                       " "
                       (rtos (cadr dPt1) 2 5)
                       " "
                       (rtos blkDist 2 5)
                       " "
                       rl
                   ) ;_  end strcat
             ) ;_  end setq
             (Make_Text (polar txtpnt (* pi 1.5) (* 3.5 txt)) blklist)
             (setq    index (1- index)
               txt   (1+ txt)
             ) ;_  end setq
             ) ; end while
             (entdel dCurve)
          ) ;_  end while
      ) ;_  end progn
      (princ "\n<!> Empty selection or this isn't a Curve (line, polyline, etc.) <!> ")
   ) ; end if
   (mapcar 'setvar varlist oldvars)
   (princ)
) ;_  end defun


;;----------------=={ Get Attribute Value }==-----------------;;
;;                                                            ;;
;;  Returns the attribute value associated with the specified ;;
;;  tag, within the supplied block, if present.               ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  block - VLA Block Reference Object                        ;;
;;  tag   - Attribute TagString                               ;;
;;------------------------------------------------------------;;
;;  Returns:  Attribute TextString, else nil                  ;;
;;------------------------------------------------------------;;
(defun LM:GetAttributeValue ( block tag )
 ;; © Lee Mac 2010
 (vl-some
   (function
     (lambda ( attrib )
       (if (eq tag (vla-get-Tagstring attrib))
         (vla-get-TextString attrib)
       )
     )
   )
   (vlax-invoke block 'GetAttributes)
 )
)

 

 

I have commented my amendments/additions with abra-cad-abra.

 

Any help guidance would be greatly appreciated.

 

Ps. Accept my apologies in advance if this code should have been posted in the original thread

[BIGAL]

Not sure what the error is but put Lee's code at top, I make sure all called defuns are loaded prior to them being used. It may be stalling as lisp starts top down, not read all then run like say .net vba etc

[abra-CAD-abra]

Thanks BIGAL,

 

I will try your suggestion and continue to study the code.

 

Thanks again for having a look.

 

Cheers