Author Topic: Add attributes one the fly  (Read 19129 times)

0 Members and 1 Guest are viewing this topic.

T.Willey

  • Needs a day job
  • Posts: 5251
Re: Add attributes one the fly
« Reply #30 on: December 15, 2005, 06:01:56 PM »
Just in case anyone wants to know, this is the final code that I will be using.  Thanks again for all the help.
Code: [Select]
(defun VALUE (num ent /)
  (cdr (assoc num ent))
)

(defun c:AddExtraAtt (/ *error* CreatAtt ActDoc Sel EntData tmpEnt flag Sel2 InsPt Ht Rot Tag Str Just tmpOpt
                        Just72 Just73 tmpEntData entmakeList)

; Add attributes until you hit enter to an existing block, while keeping the original attributes.
; Tim Willey 12/2005
; Sub's 'CreateAtt 'value '*error*
; Thanks to Jeff Mishler and Kerry Brown at www.theswamp.org for their input.

(defun *error* (msg)
 (princ msg)
 (vla-EndUndoMark ActDoc)
 (if Sel
  (redraw (car Sel) 4)
 )
)

(defun CreateAtt (Tag Str InsPt Just72 Just73 Ht Rot / )

(list
 (cons 0 "ATTRIB")
 (cons 100 "AcDbEntity")
 (cons 100 "AcDbText")
 (cons 100 "AcDbAttribute")
 (cons 1 Str)
 (cons 2 Tag)
 (cons 6 "ByBlock")
 (cons 8 "0")
 (cons 10 InsPt)
 (cons 11 InsPt)
 (cons 40 Ht)
 (cons 50 Rot)
 (cons 62 256)
 (cons 70 0)
 (cons 72 Just72)
 (cons 73 Just73)
)
)

(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-StartUndoMark ActDoc)
(while
 (and
  (if Sel
   T
   (setq Sel (entsel "\n Select block to add attribute to: "))
  )
  (setq EntData (entget (car Sel)))
  (= (value 0 EntData) "INSERT")
  (not (redraw (car Sel) 3))
  (setq entmakeList
   (list
    (if (not (assoc 66 EntData))
     (append EntData (list (cons 66  1)))
     EntData
    )
   )
  )
  (setq tmpEnt (car Sel))
  (if
   (and
    (entnext tmpent)
    (= (cdr (assoc 0 (entget (entnext tmpent)))) "ATTRIB")
   )
   (while (/= (value 0 (entget (setq tmpEnt (entnext tmpEnt)))) "SEQEND")
    (setq entmakeList (cons (setq EntData (entget tmpEnt)) entmakeList))
   )
   (setq flag T)
  )
  (not (initget "Type"))
  (setq Sel2 (nentsel "\n Select existing attribute to match, or Type in attribute properties: "))
  (if (= Sel2 "Type")
   (progn
    (setq InsPt (getpoint "\n Select insertion point: "))
    (setq Ht (getdist "\n Height of attribute: "))
    (setq Rot (getangle "\n Rotation of attribute: "))
    (/= (setq Tag (getstring T "\n Enter tag value: ")) "")
    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
    (not (initget "L C R M TL TC TR ML MC MR BL BC BR"))
    (setq Just
     (if (setq tmpOpt (getkword "\n Justification [<L>/C/R/M/TL/TC/TR/ML/MC/MR/BL/BC/BR]: "))
      tmpOpt
      "L"
     )
    )
    (cond
     ((= Just "L")
      (setq Just72 0)
      (setq Just73 0)
     )
     ((= Just "C")
      (setq Just72 1)
      (setq Just73 0)
     )
     ((= Just "R")
      (setq Just72 2)
      (setq Just73 0)
     )
     ((= Just "M")
      (setq Just72 4)
      (setq Just73 0)
     )
     ((= Just "TL")
      (setq Just72 0)
      (setq Just73 3)
     )
     ((= Just "TC")
      (setq Just72 1)
      (setq Just73 3)
     )
     ((= Just "TR")
      (setq Just72 2)
      (setq Just73 3)
     )
     ((= Just "ML")
      (setq Just72 0)
      (setq Just73 2)
     )
     ((= Just "MC")
      (setq Just72 1)
     (setq Just73 2)
     )
     ((= Just "MR")
      (setq Just72 2)
      (setq Just73 2)
     )
     ((= Just "BL")
      (setq Just72 0)
      (setq Just73 1)
     )
     ((= Just "BC")
      (setq Just72 1)
      (setq Just73 1)
     )
     ((= Just "BR")
      (setq Just72 2)
      (setq Just73 1)
     )
    )
   )
   (progn
    (setq tmpEntData (entget (car Sel2)))
    (setq Just72 (value 72 tmpEntData))
    (setq Just73 (value 73 tmpEntData))
    (setq Ht (value 40 tmpEntData))
    (setq Rot (value 50 tmpEntData))
    (while
     (and
      (not (initget "Under"))
      (not (setq InsPt (getpoint "\n Select insertion point, or Under selected text: ")))
     )
    )
    (if (= InsPt "Under")
     (setq InsPt
      (polar
       (value
        (if (and (equal (value 72 tmpEntData) 0.0) (equal (value 73 tmpEntData) 0.0))
         10
         11
        )
        tmpEntData
       )
       (- Rot (DTR 90))
       (DefaultTextSpacing (value 7 tmpEntData) Ht)
      )
     )
    )
    (/= (setq Tag (getstring T "\n Enter tag value: ")) "")
    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
   )
  )
 )   
 (setq entmakeList (cons (CreateAtt Tag Str InsPt Just72 Just73 Ht Rot) entmakeLIst))
 (mapcar 'entmake (reverse entmakeList))
 (if flag
  (entmake
   (list
    (cons 0 "SEQEND")
    (cons 100 "AcDbEntity")
    (cons 8 (value 8 EntData))
   )
  )
  (entmake (setq EntData (entget tmpEnt)))
 )
 (entdel (car Sel))
 (setq Sel (cons (entlast) Sel))
 (redraw (car Sel) 3)
)
(if Sel
 (redraw (car Sel) 4)
)
(vla-EndUndoMark ActDoc)
(princ)
)
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5251
Re: Add attributes one the fly
« Reply #31 on: January 08, 2010, 12:25:30 PM »
Just found out that in the later version of Acad that the order of dxf codes is important, so here is an update that works in '09.  I think I have done other improvements since the last posting of the code also.

Code: [Select]
(defun VALUE (num ent /)
  (cdr (assoc num ent))
)

(defun c:AddExtraAtt (/ *error* CreatAtt ActDoc Sel EntData tmpEnt flag Sel2 InsPt Ht Rot Tag Str Just tmpOpt
    Just72 Just73 tmpEntData entmakeList Lay Wid LastAttTag tmpNum NewTagDft Num Sty)
   
    ; Add attributes until you hit enter to an existing block, while keeping the original attributes.
    ; Tim Willey 12/2005
    ; Sub's 'CreateAtt 'value '*error*
    ; Thanks to Jeff Mishler and Kerry Brown at www.theswamp.org for their input.
   
    (defun *error* (msg)
        (princ msg)
        (vla-EndUndoMark ActDoc)
        (if Sel
            (redraw (car Sel) 4)
        )
    )
   
    (defun CreateAtt (Tag Str InsPt Just72 Just74 Ht Rot Sty Lay Wid / )
       
        (list
            (cons 0 "ATTRIB")
            (cons 100 "AcDbEntity")
            (cons 8 Lay)
            (cons 6 "ByBlock")
            (cons 62 256)
            (cons 100 "AcDbText")
            (cons 10 InsPt)
            (cons 40 Ht)
            (cons 1 Str)
            (cons 50 Rot)
            (cons 41 Wid)
            (cons 7 Sty)
            (cons 72 Just72)
            (cons 11 InsPt)
            (cons 100 "AcDbAttribute")
            (cons 2 Tag)
            (cons 70 0)
            (cons 74 Just74)
        )
    )
   
    (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
    (vla-EndUndoMark ActDoc)
    (vla-StartUndoMark ActDoc)
    (setq Num 1)
    (while
        (and
            (if Sel
                T
                (setq Sel (entsel "\n Select block to add attribute to: "))
            )
            (setq EntData (entget (car Sel) '("*")))
            (= (value 0 EntData) "INSERT")
            (not (redraw (car Sel) 3))
            (setq entmakeList
                (list
                    (if (not (assoc 66 EntData))
                        (append EntData (list (cons 66  1)))
                        EntData
                    )
                )
            )
            (setq tmpEnt (car Sel))
            (if
                (and
                    (entnext tmpent)
                    (= (cdr (assoc 0 (entget (entnext tmpent)))) "ATTRIB")
                )
                (while (/= (value 0 (entget (setq tmpEnt (entnext tmpEnt)))) "SEQEND")
                    (setq entmakeList (cons (setq EntData (entget tmpEnt)) entmakeList))
                    (setq LastAttTag (cdr (assoc 2 EntData)))
                    (if
                        (and
                            (wcmatch (strcase LastAttTag) "EXTRA LINE*")
                            (>= (setq tmpNum (atoi (substr LastAttTag 11))) Num)
                        )
                        (setq Num (1+ tmpNum))
                        T
                    )
                )
                (setq flag T)
            )
            (setq NewTagDft
                (strcat "EXTRA LINE"
                    (if (< Num 10)
                        (strcat "0" (itoa Num))
                        (itoa Num)
                    )
                )
            )
            (not (initget "Type"))
            (setq Sel2 (nentsel "\n Select existing attribute to match, or Type in attribute properties: "))
            (if (= Sel2 "Type")
                (progn
                    (setq InsPt (getpoint "\n Select insertion point: "))
                    (setq Ht (getdist "\n Height of attribute: "))
                    (setq Rot (getangle "\n Rotation of attribute: "))
                    (/= (setq Tag (getstring T "\n Enter tag value: ")) "")
                    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
                    (not (initget "L C R M TL TC TR ML MC MR BL BC BR"))
                    (setq Just
                        (if (setq tmpOpt (getkword "\n Justification [<L>/C/R/M/TL/TC/TR/ML/MC/MR/BL/BC/BR]: "))
                            tmpOpt
                            "L"
                        )
                    )
                    (cond
                        ((= Just "L")
                            (setq Just72 0)
                            (setq Just74 0)
                        )
                        ((= Just "C")
                            (setq Just72 1)
                            (setq Just74 0)
                        )
                        ((= Just "R")
                            (setq Just72 2)
                            (setq Just74 0)
                        )
                        ((= Just "M")
                            (setq Just72 4)
                            (setq Just74 0)
                        )
                        ((= Just "TL")
                            (setq Just72 0)
                            (setq Just74 3)
                        )
                        ((= Just "TC")
                            (setq Just72 1)
                            (setq Just74 3)
                        )
                        ((= Just "TR")
                            (setq Just72 2)
                            (setq Just74 3)
                        )
                        ((= Just "ML")
                            (setq Just72 0)
                            (setq Just74 2)
                        )
                        ((= Just "MC")
                            (setq Just72 1)
                            (setq Just74 2)
                        )
                        ((= Just "MR")
                            (setq Just72 2)
                            (setq Just74 2)
                        )
                        ((= Just "BL")
                            (setq Just72 0)
                            (setq Just74 1)
                        )
                        ((= Just "BC")
                            (setq Just72 1)
                            (setq Just74 1)
                        )
                        ((= Just "BR")
                            (setq Just72 2)
                            (setq Just74 1)
                        )
                    )
                )
                (progn
                    (setq tmpEntData (entget (car Sel2)))
                    (setq Just72 (value 72 tmpEntData))
                    (setq Just74 (value 74 tmpEntData))
                    (setq Ht (value 40 tmpEntData))
                    (setq Rot (value 50 tmpEntData))
                    (setq Lay (value 8 tmpEntData))
                    (setq Wid (value 41 tmpEntData))
                    (setq Sty (value 7 tmpEntData))
                    (not (initget "Under Above"))
                    (setq InsPt
                        (cond
                            ((getpoint "\n Select insertion point, or [Under/Above] selected attribute <Under>: "))
                            (t "Under")
                        )
                    )
                    (if (not (equal (type InsPt) 'LIST))
                        (setq InsPt
                            (polar
                                (value
                                    (if (and (equal (value 72 tmpEntData) 0.0) (equal (value 74 tmpEntData) 0.0))
                                        10
                                        11
                                    )
                                    tmpEntData
                                )
                                (rem
                                    (+
                                        Rot
                                        (if (= InsPt "Under")
                                            (* pi 1.5)
                                            (* pi 0.5)
                                        )
                                    )
                                    (* pi 2.)
                                )
                                (DefaultTextSpacing (value 7 tmpEntData) Ht)
                            )
                        )
                    )
                    (if (= (setq Tag (getstring T (strcat "\n Enter tag value <" NewTagDft ">: "))) "")
                        (setq Tag NewTagDft)
                        Tag
                    )
                    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
                )
            )
        )
        (if (not Lay)
            (setq Lay "0")
        )
        (if (not Wid)
            (setq Wid 1.0)
        )
        (setq entmakeList (cons (CreateAtt Tag Str InsPt Just72 Just74 Ht Rot Sty Lay Wid) entmakeLIst))
        (mapcar 'entmake (reverse entmakeList))
        (if flag
            (entmake
                (list
                    (cons 0 "SEQEND")
                    (cons 100 "AcDbEntity")
                    (cons 8 (value 8 EntData))
                )
            )
            (entmake (setq EntData (entget tmpEnt)))
        )
        (entdel (car Sel))
        (setq Sel (cons (entlast) Sel))
        (redraw (car Sel) 3)
    )
    (if Sel
        (redraw (car Sel) 4)
    )
    (vla-EndUndoMark ActDoc)
    (princ)
)
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

T.Willey

  • Needs a day job
  • Posts: 5251
Re: Add attributes one the fly
« Reply #32 on: March 23, 2011, 04:48:46 PM »
I messed up when letting the user enter information, so here is an updated version.

Code: [Select]
(defun VALUE (num ent /)
  (cdr (assoc num ent))
)

(defun c:AddExtraAtt (/ *error* CreatAtt ActDoc Sel EntData tmpEnt flag Sel2 InsPt Ht Rot Tag Str Just tmpOpt
    Just72 Just73 tmpEntData entmakeList Lay Wid LastAttTag tmpNum NewTagDft Num Sty)
   
    ; Add attributes until you hit enter to an existing block, while keeping the original attributes.
    ; Tim Willey 12/2005
    ; Sub's 'CreateAtt 'value '*error*
    ; Thanks to Jeff Mishler and Kerry Brown at www.theswamp.org for their input.
   
    (defun *error* (msg)
        (princ msg)
        (vla-EndUndoMark ActDoc)
        (if Sel
            (redraw (car Sel) 4)
        )
    )
   
    (defun CreateAtt (Tag Str InsPt Just72 Just74 Ht Rot Sty Lay Wid / )
       
        (list
            (cons 0 "ATTRIB")
            (cons 100 "AcDbEntity")
            (cons 8 Lay)
            (cons 6 "ByBlock")
            (cons 62 256)
            (cons 100 "AcDbText")
            (cons 10 InsPt)
            (cons 40 Ht)
            (cons 1 Str)
            (cons 50 Rot)
            (cons 41 Wid)
            (cons 7 Sty)
            (cons 72 Just72)
            (cons 11 InsPt)
            (cons 100 "AcDbAttribute")
            (cons 2 Tag)
            (cons 70 0)
            (cons 74 Just74)
        )
    )
   
    (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
    (vla-EndUndoMark ActDoc)
    (vla-StartUndoMark ActDoc)
    (setq Num 1)
    (while
        (and
            (if Sel
                T
                (setq Sel (entsel "\n Select block to add attribute to: "))
            )
            (setq EntData (entget (car Sel) '("*")))
            (= (value 0 EntData) "INSERT")
            (not (redraw (car Sel) 3))
            (setq entmakeList
                (list
                    (if (not (assoc 66 EntData))
                        (append EntData (list (cons 66  1)))
                        EntData
                    )
                )
            )
            (setq tmpEnt (car Sel))
            (if
                (and
                    (entnext tmpent)
                    (= (cdr (assoc 0 (entget (entnext tmpent)))) "ATTRIB")
                )
                (while (/= (value 0 (entget (setq tmpEnt (entnext tmpEnt)))) "SEQEND")
                    (setq entmakeList (cons (setq EntData (entget tmpEnt)) entmakeList))
                    (setq LastAttTag (cdr (assoc 2 EntData)))
                    (if
                        (and
                            (wcmatch (strcase LastAttTag) "EXTRA LINE*")
                            (>= (setq tmpNum (atoi (substr LastAttTag 11))) Num)
                        )
                        (setq Num (1+ tmpNum))
                        T
                    )
                )
                (setq flag T)
            )
            (setq NewTagDft
                (strcat "EXTRA LINE"
                    (if (< Num 10)
                        (strcat "0" (itoa Num))
                        (itoa Num)
                    )
                )
            )
            (not (initget "Type"))
            (setq Sel2 (nentsel "\n Select existing attribute to match, or Type in attribute properties: "))
            (if (= Sel2 "Type")
                (progn
                    (setq InsPt (getpoint "\n Select insertion point: "))
                    (setq Ht (getdist "\n Height of attribute: "))
                    (setq Rot (getangle "\n Rotation of attribute: "))
                    (/= (setq Tag (getstring T "\n Enter tag value: ")) "")
                    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
                    (not (initget "L C R M TL TC TR ML MC MR BL BC BR"))
                    (setq Just
                        (if (setq tmpOpt (getkword "\n Justification [<L>/C/R/M/TL/TC/TR/ML/MC/MR/BL/BC/BR]: "))
                            tmpOpt
                            "L"
                        )
                    )
                    (cond
                        ((= Just "L")
                            (setq Just72 0)
                            (setq Just74 0)
                        )
                        ((= Just "C")
                            (setq Just72 1)
                            (setq Just74 0)
                        )
                        ((= Just "R")
                            (setq Just72 2)
                            (setq Just74 0)
                        )
                        ((= Just "M")
                            (setq Just72 4)
                            (setq Just74 0)
                        )
                        ((= Just "TL")
                            (setq Just72 0)
                            (setq Just74 3)
                        )
                        ((= Just "TC")
                            (setq Just72 1)
                            (setq Just74 3)
                        )
                        ((= Just "TR")
                            (setq Just72 2)
                            (setq Just74 3)
                        )
                        ((= Just "ML")
                            (setq Just72 0)
                            (setq Just74 2)
                        )
                        ((= Just "MC")
                            (setq Just72 1)
                            (setq Just74 2)
                        )
                        ((= Just "MR")
                            (setq Just72 2)
                            (setq Just74 2)
                        )
                        ((= Just "BL")
                            (setq Just72 0)
                            (setq Just74 1)
                        )
                        ((= Just "BC")
                            (setq Just72 1)
                            (setq Just74 1)
                        )
                        ((= Just "BR")
                            (setq Just72 2)
                            (setq Just74 1)
                        )
                    )
                    (setq Sty (getvar 'TextStyle))
                )
                (progn
                    (setq tmpEntData (entget (car Sel2)))
                    (setq Just72 (value 72 tmpEntData))
                    (setq Just74 (value 74 tmpEntData))
                    (setq Ht (value 40 tmpEntData))
                    (setq Rot (value 50 tmpEntData))
                    (setq Lay (value 8 tmpEntData))
                    (setq Wid (value 41 tmpEntData))
                    (setq Sty (value 7 tmpEntData))
                    (not (initget "Under Above"))
                    (setq InsPt
                        (cond
                            ((getpoint "\n Select insertion point, or [Under/Above] selected attribute <Under>: "))
                            (t "Under")
                        )
                    )
                    (if (not (equal (type InsPt) 'LIST))
                        (setq InsPt
                            (polar
                                (value
                                    (if (and (equal (value 72 tmpEntData) 0.0) (equal (value 74 tmpEntData) 0.0))
                                        10
                                        11
                                    )
                                    tmpEntData
                                )
                                (rem
                                    (+
                                        Rot
                                        (if (= InsPt "Under")
                                            (* pi 1.5)
                                            (* pi 0.5)
                                        )
                                    )
                                    (* pi 2.)
                                )
                                (DefaultTextSpacing (value 7 tmpEntData) Ht)
                            )
                        )
                    )
                    (if (= (setq Tag (getstring T (strcat "\n Enter tag value <" NewTagDft ">: "))) "")
                        (setq Tag NewTagDft)
                        Tag
                    )
                    (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
                )
            )
        )
        (if (not Lay)
            (setq Lay "0")
        )
        (if (not Wid)
            (setq Wid 1.0)
        )
        (setq entmakeList (cons (CreateAtt Tag Str InsPt Just72 Just74 Ht Rot Sty Lay Wid) entmakeLIst))
        (mapcar 'entmake (reverse entmakeList))
        (if flag
            (entmake
                (list
                    (cons 0 "SEQEND")
                    (cons 100 "AcDbEntity")
                    (cons 8 (value 8 EntData))
                )
            )
            (entmake (setq EntData (entget tmpEnt)))
        )
        (entdel (car Sel))
        (setq Sel (cons (entlast) Sel))
        (redraw (car Sel) 3)
    )
    (if Sel
        (redraw (car Sel) 4)
    )
    (vla-EndUndoMark ActDoc)
    (princ)
)
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

chlh_jd

  • Guest
Re: Add attributes one the fly
« Reply #33 on: March 24, 2011, 05:30:05 AM »
so Great , T.Willey
In my ACAD2004 version , it can add the atts, however , the block can't used in command "_refedit" .

T.Willey

  • Needs a day job
  • Posts: 5251
Re: Add attributes one the fly
« Reply #34 on: March 24, 2011, 10:06:49 AM »
I never use ' refedit ', so wouldn't have found that out.  I think the issue would be that the block definition and the insert are not exactly the same anymore, so the command doesn't know what to do.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

Please think about donating if this post helped you.

Hugo

  • Bull Frog
  • Posts: 422
Re: Add attributes one the fly
« Reply #35 on: January 30, 2012, 03:49:11 AM »
Hallo

Get this message

Another question to
Because I can immediately select multiple blocks, or just one more.
Thank you

Have brought the Lisp and running, but if I use one ATTSYN disappears again the ATT.
why   :-( :-( :-(




Quote
Befehl:
ADDEXTRAATT
 Select block to add attribute to:
 Select existing attribute to match, or Type in attribute properties:
 Select insertion point, or [Under/Above] selected attribute <Under>:
 Enter tag value <EXTRA LINE01>: Dober

 Enter displayed value: Dober
; Fehler:  Ausnahmebedingung aufgetreten: 0xC0000005 (Zugriffsverletzung)
; Warnung: Unwind übersprungen bei Ausnahmebedingung
; Fehler:  Ausnahmebedingung aufgetreten: 0xC0000005 (Zugriffsverletzung)

Bekomme diese Meldung

Noch eine Frage dazu
Kann ich da gleich mehrere Blöcke auswählen, oder nur immer einen.

Hab das Lisp zum laufen gebracht, aber wenn ich ein ATTSYN verwende verschwindet das ATT wieder.
Wieso
Danke
« Last Edit: February 01, 2012, 10:04:56 AM by Hugo »