[编程交流] 将标记集添加到另一个L

;    .: 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))))

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

;;------------------------=={ 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  : "         )       )     )     ( *tag* )   ) ) (while (and (setq p1 (getpoint "\nSpecify First Point  : "))             (setq p2 (getpoint (strcat "\nSpecify Point for Tag (" pr (itoa *tag*) ")  : ") 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))   ) ))