Adding the Tagset to another Lisp.

[Tiger]

I have these two lisps, both made by Lee if I am not mistaken that I use routinely and love them. I am trying my darndest to get more colleges using them since they are such big timesavers! And since they are so well-written its no problem to make even then near-pension-lady across the hall use them and understand.

 

You can tell that I am buttering up to something? I know

 

The TG-lisp (places positioning numbers in circles with a leader-line) has a TAGSET command to set text-height and circle radius. The CR-lisp (places coordinates in the drawing) does not have a TAGSET which would be awesome if it had. *blink blink* Ofcourse CR doesn't need the Circle-radius...

 

I hear you sigh and say "But Tiger, why don't you do it yourself?" Well, two reasons, its friday and I am heading home soon to celebrate (long story, but the Police dropped the charges, WOHOO!) and I know there are people here that could do it so much better than me *buttering again*

 

;    .: Nozzle & Equipment Tags :.
 ;
 ;        .: by Lee McDonnell :.

(defun c:tg  (/ olderr *error* varLst oldVars tagpt tagline linent linest linend tagang tcirc tcirccent t1)

 (or (getenv "tag:tsize") (setenv "tag:tsize" (rtos (getvar "TEXTSIZE"))))
 (or (getenv "tag:tcircr") (setenv "tag:tcircr" "4.2"))
 (princ
   (strcat "\nType \"TAGSET\" to Change Base Variables  --  Current Settings:"
       "\n\tText Height: "
       (getenv "tag:tsize")
       ",\tText Circle Radius: "
       (getenv "tag:tcircr")))

 ;     --- Error Trap ---

 (setq    olderr    *error* *error*    errtrap)
 (defun errtrap  (msg)
   (mapcar 'setvar varLst oldVars)
   (setq *error* olderr)
   (if    (= msg "")
     (princ "\nFunction Complete.")
     (princ "\nError or Esc pressed... "))
   (princ))

 (setq    varLst    (list "CMDECHO" "CLAYER")
   oldVars    (mapcar 'getvar varLst))

 ;    --- Error Trap ---

 (setvar "cmdecho" 0)
 (if (not (tblsearch "LAYER" "TAGLINE"))
   (command "-layer" "m" "TAGLINE" "c" "5" "TAGLINE" ""))
 (if (not (tblsearch "LAYER" "TEXT"))
   (command "-layer" "m" "TEXT" "c" "2" "TEXT" ""))
 (while
   (/= (setq tagpt (getpoint "\nSelect First Tag Point: ")) nil)
    (setvar "clayer" "TAGLINE")
    (prompt "\nSpecify Second Point... ")
    (command "_line" tagpt pause "")
    (setq tagline (entlast)
      linent  (entget tagline)
      linest  (cdr (assoc 10 linent))
      linend  (cdr (assoc 11 linent))
      tagang  (angle linest linend)
      tcirc   (atof (getenv "tag:tcircr")))
    (setvar "clayer" "TEXT")
    (setq tcirccent (polar linend tagang tcirc))
    (command "_circle" "_non" tcirccent tcirc)
    (command "-mtext" tcirccent "H" (getenv "tag:tsize") "J" "MC" "@8.4,0" "")
    (command "_ddedit" (setq t1 (entlast)) "")
    (entmod (subst (cons 10 tcirccent) (assoc 10 (entget t1)) (entget t1))))
 (*error* "")
 (princ))

 ; Base Variables

(defun c:tagset     (/ tsize tcircr)
 (or (getenv "tag:tsize") (setenv "tag:tsize" (rtos (getvar "TEXTSIZE"))))
 (or (getenv "tag:tcircr") (setenv "tag:tcircr" "4.2"))
 (princ
   (strcat "\nCurrent Settings:"
       "\n\tText Height: "
       (getenv "tag:tsize")
       ",\tText Circle Radius @ 1:1: "
       (getenv "tag:tcircr")))
 (if (setq tsize (getreal (strcat "\nSpecify Text Height <" (getenv "tag:tsize") ">: ")))
   (setenv "tag:tsize" (rtos tsize)))
 (if (setq tcircr (getreal (strcat "\nSpecify Text Circle Radius <" (getenv "tag:tcircr") ">: ")))
   (setenv "tag:tcircr" (rtos tcircr)))
 (princ "\nBase Variables Set.")
 (princ))

(defun c:cr (/ *error* doc lFac tSze tLay tSty vl ov pt t1 t2)
 (vl-load-com)

 (setq doc (vla-get-ActiveDocument
             (vlax-get-acad-object)))

 (defun *error* (msg)
   (if doc (vla-EndUndoMark doc))
   (if ov (mapcar 'setvar vl ov))
   (if (not
         (wcmatch
           (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
     (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (setq

   lFac 1.5    ;; <<-- Line Spacing Factor

   tSze 500    ;; <<-- TextSize (nil to use TEXTSIZE sys var)

   tLay nil ;; <<-- Text Layer (nil to use CLAYER sys var)

   tSty nil    ;; <<-- Text Style (nil to use TEXTSTYLE sys var)

 )

 (setq vl '("CMDECHO" "OSMODE")
       ov (mapcar 'getvar vl))
 (setvar "CMDECHO" 0)
 (setvar "LUPREC" 3)

 ;;<<--  Error Checking  -->>

 (cond ((not (and (numberp lFac) (< 0 lFac)))
        (princ "\n** Line Spacing not Valid **"))
       ((and tLay (not (eq 'STR (type tLay))))
        (princ "\n** Layer not a String **"))
       (t

        (or tSze (setq tSze (getvar "TEXTSIZE")))
        (or tLay (setq tLay (getvar "CLAYER")))
        (or tSty (setq tSty (getvar "TEXTSTYLE")))

        (and tLay (not (tblsearch "LAYER" tLay))
             (vla-add
               (vla-get-layers doc) tLay))

;; <<---------------------->>


        ;; <<-- Business End  -->>
        
        (while (setq pt (getpoint "\n Välj Punkt - <RETURN> för att avsluta :"))
          (vla-StartUndoMark doc)
          (setvar "OSMODE" 0)
          (setq pt (trans pt 1 0))
          
          (command "_.point" pt)   ;; << Comment this if unnecessary

          (setq t1
            (Make_Text pt
              (strcat "Y: " (rtos (/ (car pt) 1000.)))
              0.  ;; Text is at 0 deg.
              tSze tLay tSty))

          (setq t2
            (Make_Text (polar pt (/ (* 3 pi) 2.) (* lFac tSze))
              (strcat "X: " (rtos (/ (cadr pt) 1000.)))
              0.
              tSze tLay tSty))

          (setvar "OSMODE" (cadr ov))

          (command "_.move" t1 t2 "" pt pause)

          (vla-EndUndoMark doc))

        ;; <<------------------>>

        ))

 (mapcar 'setvar vl ov)
 (princ))


;; <<--  Sub-Function  -->> 

(defun Make_Text  (pt val rot sZe lay sty)
 (entmakex
   (list
     (cons 0 "TEXT")
     (cons 8  lay)
     (cons 10 pt)
     (cons 40 sZe)
     (cons 1  val)
     (cons 50 rot)
     (cons 7  sty)
     (cons 71 0)
     (cons 72 0)  ;; 0 = Left, 1 = Center, 2 = Right
     (cons 73 1)  ;; 0 = Base, 1 = Bottom, 2 = Middle, 3 = Top
     (cons 11 pt))))

[Lee Mac]

Argh! My old LISP code makes me cringe...

 

If I did it now, I most probably wouldn't save the settings to the registry but maybe a cfg file perhaps...

[BlackBox]

Argh! My old LISP code makes me cringe...

 

 

... Ohh, man up, super-genious.

 

I most probably wouldn't save the settings to the registry but maybe a cfg file perhaps...

 

 

... You simply must tell me more. Sadly, I have neglected the registry in my developer training all-together.

[Lee Mac]

... You simply must tell me more. Sadly, I have neglected the registry in my developer training all-together.

 

Well, the 'tg' code as it stands stores the defaults in the registry under:

 

(strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\FixedProfile\\General"

As that is the location setenv saves values to.

 

Now, I suppose nowadays registries are large enough that a few extra keys has negligible effect, but all the same, when the program goes out of use, the key remains unless the user knows to delve through the registry to the above location to remove it... whereas a small text/cfg file is much easier to deal with.

 

Lee

[BlackBox]

Thanks for the clarification, Lee.

 

It still does not compute (yet), but I will do some reading, Googl'ing, and revisit this once I get this submittal out the door.

 

Cheers!

[Lee Mac]

Thanks for the clarification, Lee.

 

It still does not compute (yet), but I will do some reading, Googl'ing, and revisit this once I get this submittal out the door.

 

Cheers!

 

You're welcome

 

I just used the setenv/getenv functions in this case - which are, I suppose, simpler functions than vl-registry-write in that they only write to one place in the registry - I suppose the best way to learn is to try, but just be careful meddling around in the registry - that said, don't fear the registry like most seem to - its not that dangerous unless you are a complete twit and go deleting/modifying keys without knowing what they do.

[BlackBox]

... I can be a bit 'twitty'.

Edited November 5, 2010 by BlackBox

[Tiger]

Argh! My old LISP code makes me cringe...

 

If I did it now, I most probably wouldn't save the settings to the registry but maybe a cfg file perhaps...

 

Mo Ha Ha - they will always come back to haunt you you know

[Lee Mac]

BTW Tiger, I wrote this a while back, may be of use:

 

;;------------------------=={ Tag }==-------------------------;;
;;                                                            ;;
;;  Prompts the user for a tag prefix and starting tag number ;;
;;  then proceeds to add tag blocks with incrementing tag     ;;
;;  attribute until the user fails to pick a tag point.       ;;
;;                                                            ;;
;;  Tag block is created if non-existent. Tag Block layers    ;;
;;  are created if non-existent.                              ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;

(defun c:tag ( / *error* ATT BL BLK BNME DEF DOC P1 P2 PR SCL SPC )
 (vl-load-com)
 ;; © Lee Mac 2010

 (setq bNme "TAG" scl (cond ( (zerop (getvar 'DIMSCALE)) 1. ) ( (getvar 'DIMSCALE) )))

 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 
 (LM:ActiveSpace 'doc 'spc)  

 (if (not (LM:Itemp (setq blk (vla-get-Blocks doc)) bNme))
   (progn
     (setq def (vla-Add blk (vlax-3D-point '(0. 0. 0.)) bNme))
     
     (vla-put-layer (vla-AddCircle def (vlax-3D-point '(0. 0. 0.)) 5.) "0")
     
     (setq att (vla-AddAttribute def 2.5 0 "Tag Number: " (vlax-3D-point '(0. 0. 0.)) "TNO" "N1"))
     (vla-put-layer att "0")
     (vla-put-Alignment att acAlignmentMiddleCenter)
   )
 )

 (foreach l '("2" "5") (or (tblsearch "LAYER" l) (vla-Add (vla-get-layers doc) l)))

 (setq pr (getstring t "\nSpecify Tag Prefix: "))

 (setq *tag*
   (cond
     (
       (getint
         (strcat "\nSpecify Tag Number <"
           (itoa
             (setq *tag* (cond ( *tag* ) ( 1 )))
           )
           "> : "
         )
       )
     )
     ( *tag* )
   )
 )

 (while (and (setq p1 (getpoint "\nSpecify First Point <Exit> : "))
             (setq p2 (getpoint (strcat "\nSpecify Point for Tag (" pr (itoa *tag*) ") <Exit> : ") p1)))

   (vla-put-Layer
     (vla-AddLine spc
       (vlax-3D-point (trans p1 1 0))
       (vlax-3D-point (trans (polar p2 (angle p2 p1) (* 5.0 scl)) 1 0))
     )
     "5"
   )
   
   (setq bl (vla-InsertBlock spc (vlax-3D-point (trans p2 1 0)) bNme scl scl scl 0.))
   (vla-put-layer bl "2")
   
   (mapcar
     (function
       (lambda ( att )
         (if (eq "TNO" (vla-get-TagString att))
           (vla-put-TextString att (strcat pr (itoa *tag*)))
         )
       )
     )
     (vlax-invoke bl 'GetAttributes)
   )

   (setq *tag* (1+ *tag*))
 )

 (princ)
)

;;-----------------------=={ Itemp }==------------------------;;
;;                                                            ;;
;;  Retrieves the item with index 'item' if present in the    ;;
;;  specified collection, else nil                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  coll - the VLA Collection Object                          ;;
;;  item - the index of the item to be retrieved              ;;
;;------------------------------------------------------------;;
;;  Returns:  the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;

(defun LM:Itemp ( coll item )
 ;; © Lee Mac 2010
 (if
   (not
     (vl-catch-all-error-p
       (setq item
         (vl-catch-all-apply
           (function vla-item) (list coll item)
         )
       )
     )
   )
   item
 )
)

;;--------------------=={ ActiveSpace }==---------------------;;
;;                                                            ;;
;;  Retrieves pointers to the Active Document and Space       ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  *doc - quoted symbol other than *doc                      ;;
;;  *spc - quoted symbol other than *spc                      ;;
;;------------------------------------------------------------;;

(defun LM:ActiveSpace ( *doc *spc )
 ;; © Lee Mac 2010
 (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))
   )
 )
)

[Tiger]

Thanks Lee, I like that I can enter the number by hand (need to make breaks in the numbering suit sometimes) in your previous lisp so I stick with that one though :wink: