TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: T.Willey on December 13, 2005, 01:04:33 PM

Title: Add attributes one the fly
Post by: T.Willey on December 13, 2005, 01:04:33 PM
I have searched and didn't find what I was looking for, or maybe I just didn't understand fully what I was reading, but here is my question.

I was wondering how you would add attributes one the fly? No code needed just theory.  It looks like some people were re-entmake'ing the block, and then entmake'ing attributes, and then entmake'ing the seqend object, is this the only way?

I'm just a little lost.

Thanks in advance.
Tim
Title: Re: Add attributes one the fly
Post by: Jeff_M on December 13, 2005, 01:31:42 PM
Well, if you are wanting to add attributes to existing blocks.....this is how I'd approach it:
1. Forget (entmake)(entmod)
2. Recall ActiveX
3. Add the attribute to the block def
4. Collect SS of any inserts
5. Insert new block at each exist insert & set att's & props to match old
6. Check if any Xdata attached and copy if so,
7. Delete the old block
Title: Re: Add attributes one the fly
Post by: T.Willey on December 13, 2005, 01:37:40 PM
3. Add the attribute to the block def

I was hoping to do this without changing the block definition.  I was looking at doing it as a "per block" instance.

Tim
Title: Re: Add attributes one the fly
Post by: Jeff_M on December 13, 2005, 02:21:33 PM
OK, to be honest I'd never thought of doing this and so didn't know it was possible. But after a bit of testing, it looks like the method you describe is the only way without going to ObjectARX.

If you'd like to see my sample code, just holler.....
Title: Re: Add attributes one the fly
Post by: T.Willey on December 13, 2005, 02:30:19 PM
Thanks for the conformation Jeff.  Let me see what I can come up with, and then I will look at yours to see how much better it is.

Now all I have to figure out is what are the necessary dxf codes to create a block on the fly.  I always mess that up.

Thanks as always.
Tim
Title: Re: Add attributes one the fly
Post by: Jürg Menzi on December 13, 2005, 03:12:08 PM
Hmmm... I had a similar problem.
To solve that, I've copied the block definition by 'VxCloneBlockRef' (see my homepage -> Free Stuff) to a new (random) name. Then add the additional object(s) to the copied definition. Finally I had only to set the concerned insert to the new name. 8-)
Title: Re: Add attributes one the fly
Post by: T.Willey on December 13, 2005, 06:33:56 PM
Okay.  Here is my code, that seems to work on my testing here.  Fun little exercise.  Any comments welcomed.  It will add attributes to xref's also.
Code: [Select]
(defun VALUE (num ent /)
  (cdr (assoc num ent))
)

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

; Add attributes until you hit enter to an existing block, while keeping the original attributes.
; Tim Willey 12/2005
; Sub's 'CreateAtt 'value
; 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 / )

(entmake
 (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)
(if
 (and
  (setq Sel (entsel "\n Select block to add attribute to: "))
  (setq EntData (entget (car Sel)))
  (= (value 0 EntData) "INSERT")
  (not (redraw (car Sel) 3))
 )
 (progn
  (if (not (assoc 66 EntData))
   (entmake (append EntData (list (cons 66  1))))
   (entmake 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")
    (entmake (setq EntData (entget tmpEnt)))
   )
   (setq flag T)
  )
  (while
   (and
    (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 InsPt (getpoint "\n Select insertion point: "))
      (/= (setq Tag (getstring T "\n Enter tag value: ")) "")
      (/= (setq Str (getstring T "\n Enter displayed value: ")) "")
      (setq Just72 (value 72 (entget (car Sel2))))
      (setq Just73 (value 73 (entget (car Sel2))))
      (setq Ht (value 40 (entget (car Sel2))))
      (setq Rot (value 50 (entget (car Sel2))))
     )
    )
   )   
   (CreateAtt Tag Str InsPt Just72 Just73 Ht Rot)
  )
  (if flag
   (entmake
    (list
     (cons 0 "SEQEND")
     (cons 100 "AcDbEntity")
     (cons 8 (value 8 EntData))
    )
   )
   (entmake (setq EntData (entget tmpEnt)))
  )
  (entdel (car Sel))
 )
)
(vla-EndUndoMark ActDoc)
(princ)
)
Tim

Updated per Jeff's code
Updated per Kerry's post
Update code.  Added error trap, and the ability to select attribute to match height, rotation and justification properties.
Title: Re: Add attributes one the fly
Post by: Jeff_M on December 13, 2005, 07:07:05 PM
Looks good to me, Tim. The only thing I can find to recommend is that if the user selects something other than a block you will get some unexpected behavior. I would add a check immediately after the (entsel) to verify that a Block was selected. Something like this:
Code: [Select]
(if (and (setq Sel (entsel "\ Select block to add attribute to: "))
(setq EntData (entget (car Sel)))
(eq (cdr (assoc 0 EntData)) "INSERT")
)
(progn
  ;;(setq EntData (entget (car Sel)));;this was moved up
  (if (not (assoc 66 EntData))
Good Job!
Title: Re: Add attributes one the fly
Post by: CADaver on December 13, 2005, 07:09:18 PM
What happens if the block is ATTSYNC'd later?
Title: Re: Add attributes one the fly
Post by: T.Willey on December 13, 2005, 07:12:58 PM
Thanks Jeff.  I usually do that, but had it that way when coding and testing, but forgot to change this one.  Care to share your code now?  I like seeing how others do things, so that I can learn.  I will change the one I have here, and I guess I can change the code I posted also.

Tim

ps.
CADaver,

  I don't use ATTSYNC, but I don't think there is anyway to keep it from getting lost with attsync because I don't want to change the blocks definition in the blocks collection (table).  Maybe someone else would like to share.
Title: Re: Add attributes one the fly
Post by: Jeff_M on December 13, 2005, 07:39:35 PM
Tim,
The code I had was just some tinkering to see what could be done. Instead of asking for the text size/rotation I copied an existing attribute (not much use when the block doesn't have any) and only input the Tag/Text strings. But again, I wasn't trying to come up witha solution as you have done.....I was curious if it could be done..... And somewhere along the line today I closed that session without saving my doodlings.

ATTSYNC, In the past 15 years I've used it once. Oh, and welcome back Randy!

Just out of curiosity....what is the purpose of adding an attribute to a block in this fashion? I've tried to think of a scenario that I could utilize this, but have come up empty.
Title: Re: Add attributes one the fly
Post by: Kerry on December 13, 2005, 07:42:39 PM
Hi Tim,

Looks fine to me.
Recommendation to polish :
ActDoc variable could be local
Add an error trap to ensure (vla-EndUndoMark ActDoc) is called if the user dummy-spits.

Interesting alternative : If you have a bit of time < hehehe > having an ActiveX <vla-..> version to compare may be interesting.

ditto Jeff's usage comment ^ ^



Title: Re: Add attributes one the fly
Post by: Jeff_M on December 13, 2005, 07:59:56 PM
< hehehe > having an ActiveX <vla-..> version to compare may be interesting.
He might need a bunch of time Kerry. I haven't researched beyond this snip in the Docs:
Quote from: ActiveX AttRef Help
You cannot directly create an attribute reference. Attribute references are added to the drawing when a block containing an attribute definition is inserted into the drawing.
but if you have any ideas....:)
Title: Re: Add attributes one the fly
Post by: Kerry on December 13, 2005, 08:40:46 PM
Must admit I haven't tried making attributed blocks with the ActiveX Library Jeff .. just conventional blocks.


.. I'm still having difficulty coming to terms with the original post idea of having blocks with the same name having different definitions.
The hairs on the back of my neck are standing up.
Title: Re: Add attributes one the fly
Post by: whdjr on December 14, 2005, 07:11:06 AM
.. I'm still having difficulty coming to terms with the original post idea of having blocks with the same name having different definitions.
The hairs on the back of my neck are standing up.

That's a big DITTO!!!!  You have all kinds of troubles with your blocks then which is what randy was trying to say.  If you change a block and add an attribute to it, then the only way (even after redefining the block) for the previously inserted block defs to have the correct attributes is an attsync.



Welcome back Randy  :-)
Title: Re: Add attributes one the fly
Post by: Jürg Menzi on December 14, 2005, 07:18:30 AM
That's a big DITTO!!!!  You have all kinds of troubles with your blocks then which is what randy was trying to say.  If you change a block and add an attribute to it, then the only way (even after redefining the block) for the previously inserted block defs to have the correct attributes is an attsync. (...)
That's the reason for my suggestion to copy the block definition to a new name. In my solution I use the old block name and append a random number: MyOldBlockName_nnnnnnnn
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 11:13:17 AM
This was and idea.  I like the fact of title blocks being xrefs, but I don't like having so much loose text associated with them, this way one could have an xref'ed title block with attributes.  But mostly it was just an idea I saw from another post, and just wondered if it was possible.  I might never use it because I don't have control over the title blocks where I work.  I can't give any other ideas right now, but if I think of some I will let you all know.

Kerry,
 Thanks for pointing out that I didn't make a variable local.  I write my code, and then at the end go back and make them all local.  I think I was too happy that I got it to work that I missed so minor things that I usually don't, like what Jeff pointed out first.  I was thinking ActiveX first, but didn't think it could be done, but that would be fun to look into.

Thanks for all the comments and corrections.
Tim
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 12:08:21 PM
If anyone would be so kind as to post how to create blocks on the fly with ActiveX controls I will experiment when I have some time.  I don't see how it is done when looking through the help files.

Thanks.
Tim
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:16:10 PM
Hi Tim,

Here are some portions of code I have done in the past to generate via vlisp-activex blocks with attributes, HTH

Code: [Select]
;;; Command: RWIZ-BUBBLE
;;;
;;; Description: Generates a circle bubble symbol
;;;
;;; Objects:
;;; 1. Bubble block
;;; - Circle
;;; - One attribute
;;;=============================================================

(defun circular-bubble-blk  (/ radius    p0
     vla_circle ss    obj
     vla_block vla_att1   block_name
     return)

  (setq block_name "RWIZ-REF-CIRCLE")

  (cond
    ;; the block already exist, return the name
    ((not
       (vl-catch-all-error-p
(setq vla_block (vl-catch-all-apply
   'vla-item
   (list (vla-get-blocks (rwiz-thisDwg))
block_name)))))
     (setq return (vla-get-name vla_block)))

    ;; make the block
    ((vl-catch-all-error-p
       (vl-catch-all-apply
'vla-item
(list (vla-get-blocks (rwiz-thisdwg)) block_name)))

     (setq radius 0.15625)

     (setq p0 (list 0.0 0.0 0.0))

     (setq vla_circle (rwiz-addcircle p0 radius))

     (vla-put-layer vla_circle "0")
     (vla-put-color vla_circle acbyblock)

     (setq ss (ssadd))
     (ssadd (vlax-vla-object->ename vla_circle) ss)

     (setq vla_block (rwiz-addblock
       (list 0.0 0.0 0.0)
       block_name
       ss
       T))

     (setq
       vla_att1 (vla-addattribute
  vla_block
  0.09375
  acattributemodeverify
  "NUMBER"
  (vlax-3D-Point p0)
  "NUM"
  "#"))

     (vla-put-layer vla_att1 "0")
     (vla-put-color vla_att1 acbyblock)

     (vla-put-alignment vla_att1 acalignmentmiddlecenter)
     (vla-put-verify vla_att1 :vlax-false)
     (vla-put-textalignmentpoint vla_att1 (vlax-3D-Point p0))

     (setq return (vla-get-name vla_block))))
  return)
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:17:23 PM
Another sample:

Code: [Select]
;;; Description: Generates a detail symbol
;;;
;;; Objects:
;;; 1. Bubble block
;;; - Circle
;;; - Two attributes
;;; 2. Two lines
;;;=============================================================

;;;_____________________________________________________________
(defun reference-bubble-blk  (/ radius   rad/2     p0
      vla_circle   p1     p2
      vla_line p3   p4     ss
      obj vla_block vla_att1  vla_att2
      block_name   return)

  ;; name of the block
  (setq block_name "REF-BUBBLE")

  (cond
    ;; the block already exist, return the name
    ((not
       (vl-catch-all-error-p
(setq vla_block (vl-catch-all-apply
   'vla-item
   (list (vla-get-blocks (rwiz-thisDwg))
block_name)))))
     (setq return (vla-get-name vla_block)))

    ;; make the block
    ((vl-catch-all-error-p
       (vl-catch-all-apply
'vla-item
(list (vla-get-blocks (rwiz-thisdwg)) block_name)))

     ;; basic data for the block
     (setq radius 0.25)
     (setq rad/2 (/ radius 2.0))
     (setq p0 (list 0.0 0.0 0.0))

     ;; draw the vla_circle
     (setq vla_circle (rwiz-addCircle p0 radius))
     (vla-put-layer vla_circle "0")
     (vla-put-color vla_circle acbyblock)

     (setq p1 (polar p0 pi radius))
     (setq p2 (polar p0 0.0 radius))

     ;; draw the vla_line
     (setq vla_line (rwiz-addLine p1 p2))
     (vla-put-layer vla_line "0")
     (vla-put-color vla_line acbyblock)

     (setq p3 (polar p0 :rwiz_90Degrees rad/2))
     (setq p4 (polar p0 :rwiz_270Degrees rad/2))

     ;; create a selection set
     (setq ss (ssadd))
     ;; pass all the new objects to the selection set
     (foreach obj  (list vla_circle vla_line)
       (ssadd (vlax-vla-object->ename obj) ss))

     ;; generate the block
     (setq
       vla_block (rwiz-addBlock
   (list 0.0 0.0 0.0)
   block_name
   ss
   T))

     ;; generate the first attribute object
     (setq
       vla_att1 (vla-addattribute
  vla_block
  0.09375
  acattributemodeverify
  "DETAIL_NUMBER"
  (vlax-3D-Point p3)
  "DNUMBER"
  "#"))

     ;; pass the attribute object
     ;; to layer "0" and use of "byblock"
     (vla-put-layer vla_att1 "0")
     (vla-put-color vla_att1 acbyblock)

     ;; place the attribute centered
     (vla-put-alignment vla_att1 acalignmentmiddlecenter)
     ;; do not use the attribute verification
     ;; when inserted
     (vla-put-verify vla_att1 :vlax-false)
     ;; place the attribute in the his position
     (vla-put-textalignmentpoint vla_att1 (vlax-3D-Point p3))

     ;; generate the second attribute
     (setq
       vla_att2
(vla-addattribute
  vla_block
  0.09375
  acattributemodeverify
  "SHEET_NUMBER"
  (vlax-3D-Point p4)
  "SNUMBER"
  "#"))

     (vla-put-layer vla_att2 "0")
     (vla-put-color vla_att2 acbyblock)

     ;; place the attribute centered
     (vla-put-alignment vla_att2 acalignmentmiddlecenter)
     ;; do not use the attribute verification
     ;; when inserted
     (vla-put-verify vla_att2 :vlax-false)
     ;; place the attribute in the his position
     (vla-put-textalignmentpoint vla_att2 (vlax-3D-Point p4))

     (setq return (vla-get-name vla_block))))
  return)
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:18:34 PM
Another one:

Code: [Select]
;;; Description: Generates a keynote symbol
;;;
;;; Objects:
;;; 1. Bubble block
;;; - Circle
;;; - One attribute
;;; 2. One line
;;; 3. Arrowhead
;;; - Lwpolyline
;;; - Hatch
;;;=============================================================

;;;_____________________________________________________________
(defun keynote-bubble-blk  (/        radius   p0      vla_circle
    ss        obj   vla_block  vla_att1
    block_name return)

  (setq block_name "SYM-REF-CIRCLE")

  (cond
    ;; the block already exist, return the name
    ((not
       (vl-catch-all-error-p
(setq vla_block (vl-catch-all-apply
   'vla-item
   (list (vla-get-blocks (rwiz-thisdwg))
block_name)))))
     (setq return (vla-get-name vla_block)))

    ;; make the block
    ((vl-catch-all-error-p
       (vl-catch-all-apply
'vla-item
(list (vla-get-blocks (rwiz-thisdwg)) block_name)))

     (setq radius 0.15625)

     (setq p0 (list 0.0 0.0 0.0))

     ;; make the circle
     (setq vla_circle (rwiz-addcircle p0 radius))

     ;; put the circle on layer 0
     (vla-put-layer vla_circle "0")
     ;; put the circle by block
     (vla-put-color vla_circle acbyblock)

     ;; make an empty selection set
     (setq ss (ssadd))
     ;; pass the object to selection set
     (ssadd (vlax-vla-object->ename vla_circle) ss)

     ;; make the block
     (setq vla_block (rwiz-addblock
       (list 0.0 0.0 0.0)
       block_name
       ss
       T))

     ;; make the attribute
     (setq
       vla_att1 (vla-addattribute
  vla_block
  0.09375
  acattributemodeverify
  "NUMBER"
  (vlax-3d-point p0)
  "NUM"
  "#"))

     ;; put the attribute on layer 0
     (vla-put-layer vla_att1 "0")
     ;; put the attribute by block
     (vla-put-color vla_att1 acbyblock)

     ;; align the attribute middle center
     (vla-put-alignment vla_att1 acalignmentmiddlecenter)
     ;; not verify the attribute at insertion
     (vla-put-verify vla_att1 :vlax-false)
     ;; put the attribute on his alignment point
     (vla-put-textalignmentpoint vla_att1 (vlax-3d-point p0))

     ;; block name
     (setq return (vla-get-name vla_block))))
  return)
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:20:08 PM
and some utilities, that you might have done it already:

Code: [Select]
;;;=============================================================
;;; REACTORSWIZ [Version 1.0.0 - 3/4/04]
;;; Copyright © 2003-2004, Luis Esquivel
;;;
;;;    The use of this software is governed by the terms and
;;; conditions of the License Agreement you accepted prior
;;; to installation of this software. Read the License
;;; Agreement file: RWIZ_LICENSE_AGREEMENT.TXT
;;;
;;;    LUIS ESQUIVEL PROVIDES THIS PROGRAM "AS IS" AND WITH
;;; ALL FAULTS. LUIS ESQUIVEL SPECIFICALLY DISCLAIMS ANY
;;; IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS FOR A
;;; PARTICULAR USE. LUIS ESQUIVEL DOES NOT WARRANT THAT
;;; THE OPERATION OF THE PROGRAM WILL BE UNINTERRUPTED
;;; OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government
;;; is subject to restrictions set forth in FAR 52.227-19
;;; (Commercial Computer Software - Restricted Rights) and
;;; DFAR 252.227-7013(c)(1)(ii) (Rights in Technical Data
;;; and Computer Software), as applicable.
;;;
;;; Luis Esquivel
;;;
;;; Function utilities
;;;
;;; Note:
;;; Please note that only the functions with my initials LE
;;; were written and are copyright by Luis Esquivel.
;;; Others are copyright by their own owners.
;;;=============================================================

;; degrees
(setq :rwiz_45degrees (* pi 0.25))
(setq :rwiz_90degrees (* pi 0.5))
(setq :rwiz_135degrees (* pi 0.75))
(setq :rwiz_225degrees (* pi 1.25))
(setq :rwiz_270degrees (* pi 1.5))
(setq :rwiz_315degrees (* pi 1.75))
(setq :rwiz_360degrees (* pi 2.0))

;;;_____________________________________________________________

;; get acad object object
;; LE
(or :rwiz_acad
    (setq :rwiz_acad (vlax-get-acad-object)))

;;;_____________________________________________________________

;;; get active drawing object
;;; LE
(defun rwiz-thisdwg () (vla-get-activedocument :rwiz_acad))

;; global variable for this drawing
;; LE
;;;(or :rwiz_thisdwg (setq :rwiz_thisdwg (rwiz-thisdwg)))

(setq
  :rwiz_thisdwg
   (cond (:rwiz_thisdwg)
((rwiz-thisdwg))
(t (rwiz-thisdwg))))

;;;_____________________________________________________________

;; get model space object
;; LE
(or :rwiz_model
    (setq :rwiz_model
   (vla-get-modelspace (rwiz-thisdwg))))

;;;_____________________________________________________________

;;; get paper space object
;;; LE
(defun rwiz-pspace () (vla-get-paperspace (rwiz-thisdwg)))

;;;_____________________________________________________________

;;; get active space object
(defun rwiz-get-activespace  ()
  (if (= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
    :rwiz_model
    (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
      :rwiz_model
      (rwiz-pspace))))

;;;_____________________________________________________________

;;; get active space name "Model" or "Paper"
(defun rwiz-activespacename  ()
  (cond
    ((= acmodelspace (vla-get-activespace (rwiz-thisdwg)))
     "Model")
    (t
     (if (= (vla-get-mspace (rwiz-thisdwg)) :vlax-true)
       "Model"
       "Paper"))))

;;;_____________________________________________________________

;;; adjust dimscale, it will use 1.0 factor when is in paper space
;;; sc = scale factor as real
;;; LE
(defun rwiz-adjust-dimscale  (sc)
  (if (= (rwiz-activespacename) "Model")
    sc
    1.0))

;;;_____________________________________________________________

;;; list to variant array
;;; ptslist = point list
(defun rwiz-list-variantarray  (ptslist / arrayspace sarray)
  (setq arrayspace
(vlax-make-safearray
   ;; element type
   vlax-vbdouble
   ;; array dimension
   (cons 0
(- (length ptslist) 1))))
  (setq sarray (vlax-safearray-fill arrayspace ptslist))
  ;; return array variant
  (vlax-make-variant sarray))

;;;_____________________________________________________________

;;; 3d point to 2d point
;;; 3dpt = 3d point
(defun rwiz-3dpt-2dpt  (3dpt)
  (list (float (car 3dpt)) (float (cadr 3dpt))))

;;;_____________________________________________________________

;;; selection set to vla objects list
;;; ss = selection set
(defun rwiz-ss-vla-list (ss / index vlalist)
  (setq index (if ss
(1- (sslength ss))
-1))
  (while (>= index 0)
    (setq vlalist (cons
    (vlax-ename->vla-object
      (ssname ss index))
    vlalist)
  index   (1- index)))
  vlalist)

;;;_____________________________________________________________

;;; selection set to array
;;; ss = selection set
(defun rwiz-ss-array  (ss / c r)
  (setq c -1)
  (repeat (sslength ss)
    (setq r (cons (ssname ss (setq c (1+ c))) r)))
  (setq r (reverse r))
  (vlax-safearray-fill
    (vlax-make-safearray
      vlax-vbobject
      (cons 0 (1- (length r))))
    (mapcar 'vlax-ename->vla-object r)))

;;;_____________________________________________________________

;;; array of vbobject's
;;; vla_lst = vla-object list
;;; LE
(defun rwiz-array-vbobject  (vla_lst)
  (vlax-safearray-fill
    (vlax-make-safearray
      vlax-vbobject
      (cons 0 (1- (length vla_lst))))
    vla_lst))

;;;_____________________________________________________________

;;; make block
;;; usage:
;;; (rwiz-makeblock (list 0.0 0.0 0.0) "BLOCKNAME" selection_set T)
;;; flag:
;;; t = delete objects
;;; nil = keep objects
;;; LE
(defun rwiz-makeblock  (pt name ss flag / ssarray vla_block)
  (vla-copyobjects
    (rwiz-thisdwg)
    (setq ssarray (rwiz-ss-array ss))
    (setq vla_block (vla-add (vla-get-blocks (rwiz-thisdwg))
     (vlax-3d-point pt)
     name)))
  ;; delete objects
  (if (and flag
   ssarray
   (= (type ssarray) 'safearray)
   ;; is the safearray made of vlax-object's
   (= (vlax-safearray-type ssarray) 9))
    (mapcar 'vla-delete (safearray-value ssarray)))
  vla_block)

;;;_____________________________________________________________

;;; add block
;;; usage:
;;; (rwiz-addblock (list 0.0 0.0 0.0) "BLOCKNAME" selection_set T)
;;; flag:
;;; t = delete objects
;;; nil = keep objects
;;; LE
(defun rwiz-addblock  (pt name ss flag / vla_block)
  (if (not (vl-catch-all-error-p
     (setq vla_block
    (vl-catch-all-apply
      'rwiz-makeblock
      (list pt name ss flag)))))
    vla_block))

;;;_____________________________________________________________

;;; insert block
;;; (rwiz-insertBlock (list 0.0 0.0 0.0) "BLOCKNAME" 1.0 1.0 1.0 0.0)
;;; LE
(defun rwiz-insertblock
(insertionpoint   name
  xscale      yscale   zscale
  rotation    /   vla_insert)
  (if (not (vl-catch-all-error-p
     (setq vla_insert
    (vl-catch-all-apply
      'vla-insertblock
      (list (rwiz-get-activespace)
    (vlax-3d-point insertionpoint)
    name
    xscale
    yscale
    zscale
    rotation)))))
    vla_insert))

;;;_____________________________________________________________

;;; add circle
;;; usage:
;;; (rwiz-addcircle (list 0.0 0.0 0.0) 4.0)
;;; LE
(defun rwiz-addcircle  (center radius / vla_circle)
  (if (not (vl-catch-all-error-p
     (setq vla_circle
    (vl-catch-all-apply
      'vla-addcircle
      (list (rwiz-get-activespace)
    (vlax-3d-point center)
    radius)))))
    vla_circle))

;;;_____________________________________________________________

;;; add lwpolyline
;;; (rwiz-addlwpoly (list p1 p2 p3 p4) t)
;;; flag:
;;; t = closed
;;; nil = not closed
(defun rwiz-addlwpoly  (lst flag / vla_poly)
  (if (not (vl-catch-all-error-p
     (setq vla_poly
    (vl-catch-all-apply
      'vla-addlightweightpolyline
      (list (rwiz-get-activespace)
    (rwiz-list-variantarray
      (apply 'append
     (mapcar 'rwiz-3dpt-2dpt lst))))))))
    (if flag
      (vla-put-closed vla_poly t)))
  vla_poly)

;;;_____________________________________________________________

;;; add line
;;; usage:
;;; (rwiz-addline (list 0.0 0.0 0.0) (list 4.0 4.0 0.0))
;;; LE
(defun rwiz-addline  (start_point end_point / vla_line)
  (if (and start_point
   end_point
   (not (vl-catch-all-error-p
  (setq
    vla_line
     (vl-catch-all-apply
       'vla-addline
       (list (rwiz-get-activespace)
     (vlax-3d-point start_point)
     (vlax-3d-point end_point)))))))
    vla_line))

;;;_____________________________________________________________

;;; degrees to radians
(defun rwiz-dtr (x) (* pi (/ x 180.0)))

;;;_____________________________________________________________

;;; radians to degrees
(defun rwiz-rtd (a) (* (/ a pi) 180.0))

;;;_____________________________________________________________

;;; dxf
(defun rwiz-dxf (g e)
  (cond
    ((= (type e) 'ename) (cdr (assoc g (entget e))))
    ((= (type e) 'list) (cdr (assoc g e)))))

;;;_____________________________________________________________

;;; get attributes from a block
;;; LE
(defun rwiz-get-attributes  (vla_blk / lst)
  (if (and vla_blk
   (= (type vla_blk) 'vla-object)
   (not (vlax-erased-p vla_blk))
   (= (vla-get-objectname vla_blk) "AcDbBlockReference")
   (= (vla-get-hasattributes vla_blk) :vlax-true)
   (not (vl-catch-all-error-p
  (setq
    lst
     (vl-catch-all-apply
       'vlax-safearray->list
       (list (vlax-variant-value
       (vla-getattributes vla_blk))))))))
    lst
    nil))

;;;_____________________________________________________________

;;; check if all characters are lowercase
;;; (rwiz-all-lowercase "adsadsadsadsasad")
(defun rwiz-all-lowercase  (string)
  (vl-every
    (function
      (lambda (ltr)
(and (>= (chr ltr) "a") (<= (chr ltr) "z"))))
    (vl-string->list string)))

;;;_____________________________________________________________

;;; check if all characters are uppercase
;;; (rwiz-all-uppercase "DSADSADSADSADSADSADSADSADSADSADSADSA")
(defun rwiz-all-uppercase  (string)
  (vl-every
    (function
      (lambda (ltr)
(and (>= (chr ltr) "A") (<= (chr ltr) "Z"))))
    (vl-string->list string)))

;;;_____________________________________________________________

;;; return T if all elements in a list are equal:
(defun rwiz-list-equal (lst / first)
  (setq first (car lst))
  (vl-every (function (lambda (x) (equal first x 0.0001)))
    (cdr lst)))

;;;_____________________________________________________________

;;; check if a block is uniform scaled
;;; LE
(defun rwiz-get-uniform-scale-factor  (vla_blk)
  (rwiz-list-equal
    (list (vla-get-xscalefactor vla_blk)
  (vla-get-yscalefactor vla_blk)
  (vla-get-zscalefactor vla_blk))))

;;;_____________________________________________________________

;;; make a block uniform scaled base on a scale factor
;;; LE
(defun rwiz-put-uniform-scale-factor  (vla_blk factor / flag)
  (if (vlax-write-enabled-p vla_blk)
    (progn
      (if (/= (vla-get-xscalefactor vla_blk) factor)
(progn
  (vla-put-xscalefactor vla_blk factor)
  (setq flag t)))

      (if (/= (vla-get-yscalefactor vla_blk) factor)
(progn
  (vla-put-yscalefactor vla_blk factor)
  (setq flag t)))

      (if (/= (vla-get-zscalefactor vla_blk) factor)
(progn
  (vla-put-zscalefactor vla_blk factor)
  (setq flag t)))))
  flag)

;;;_____________________________________________________________

;;; scan a ename block and return a list of type and ename
;;; (rwiz-scanblock-lst blk)
;;; (("TEXT" <Entity name: 7ef57ec0>)
;;;  ("LINE" <Entity name: 7ef57ec8>)
;;;  ("CIRCLE" <Entity name: 7ef57ed0>)
;;;  ("LWPOLYLINE" <Entity name: 7ef57ed8>))
;;; LE
(defun rwiz-scanblock-lst  (blk / enext entnames)
  (setq enext
(cdr
   (assoc
     -2
     (tblsearch
       "block"
       (rwiz-dxf 2 (entget blk))))))
  (while enext
    (setq entnames
   (cons (list (rwiz-dxf 0 (entget enext)) enext)
entnames))
    (setq enext (entnext enext)))
  (reverse entnames))

;;;_____________________________________________________________

;;; translate a list of point to a base point
;;; LE
(defun rwiz-transpts  (lst pt / p0 p1 ang pin ang pt1 lst1)
  (setq p0  (car lst)
p1  (cadr lst)
ang (angle p0 p1)
pin (inters p0 p1 pt (polar pt (+ ang (/ pi 2)) 1) nil)
ang (angle pin pt))
  (foreach p  lst
    (setq pt1  (polar p ang (distance pt pin))
  lst1 (append lst1 (list pt1))))
  lst1)

;;;_____________________________________________________________

;;; convert the array to a list
;;; LE
(defun rwiz-get-insertionpoint (vla_obj)
  (vlax-safearray->list
    (vlax-variant-value
      (vla-get-insertionpoint vla_obj))))

;;;_____________________________________________________________

;;; convert the array to a list
;;; LE
(defun rwiz-get-startpoint  (vla_obj)
  (vlax-safearray->list
    (vlax-variant-value
      (vla-get-startpoint vla_obj))))

;;;_____________________________________________________________

;;; convert the array to a list
;;; LE
(defun rwiz-get-endpoint  (vla_obj)
  (vlax-safearray->list
    (vlax-variant-value
      (vla-get-endpoint vla_obj))))

;;;_____________________________________________________________

;;; ability to drag an move a vla object
;;; msg: optional message by default uses "Move"
;;; LE
(defun rwiz-drag-move  (msg vla_obj / take code5 p3)
  (prompt (strcat "\n"
  (cond (msg)
("Move"))
  "\n"))
  (while (and (setq take (grread 't)) (/= 3 (car take)))
    (setq code5 (car take))
    (setq p3 (cadr take))
    (if (and p3 (= 5 code5))
      (vla-move vla_obj
(vla-get-insertionpoint vla_obj)
(vlax-3d-point p3)))))

;;;_____________________________________________________________

;;; (rwiz-unhighligthem ss)
(defun rwiz-unhighligthem  (ss)
  (sssetfirst nil ss)
  (sssetfirst nil))

;;;_____________________________________________________________

(princ)
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 12:34:28 PM
Luis,
  Thanks for sharing.  I was looking at the code, and it looks to me that you are adding a block to the block collection.  Is that true?  Does that do the same thing as entmake?  I didn't think it did, but I could be wrong.  I was looking for something that did the same thing as entmake but with ActiveX controls.  If your code is the right way to do it, then I don't think it can be done because it changes the block definition, and that is what I was trying to avoid.

Tim
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:40:58 PM
Yes.... but there are ways in activex to add or remove parts of a block directly.... let me see if I have done such.... don't remember.

hmm... sorry I did not read the whole [enchilada] topic.


Luis.
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 12:48:25 PM
Tim;

Have you been lately at the www.acadx.com ? there is some visual lisp functions that might help you... ie. ax:AddObjectsToBlock ?

HTH.
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 12:54:15 PM
Luis,
  I haven't been there in awhile, but they didn't have anything that looks like what I'm trying to do.  Thanks for reminding me about that site though.

Tim
Title: Re: Add attributes one the fly
Post by: Jeff_M on December 14, 2005, 01:36:46 PM
Tim, the Add method to the Blocks collection is sorta the same as entmake for a block definition, except the EndBlock is added for you and you can place anything into the block. However, there is no ActiveX equal for entmaking an insert, since the AddInsert method inserts the block & all attributes.

FWIW, this may be a viable option for what your concerns were: "I like the fact of title blocks being xrefs, but I don't like having so much loose text associated with them, this way one could have an xref'ed title block with attributes". Why not use an Xref for all static portions of the Title Block and use a standard block w/attributes for the "loose" text/attributes? This way your Title block is composed of 2 objects (which you could Group together).
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 01:45:15 PM
However, there is no ActiveX equal for entmaking an insert, since the AddInsert method inserts the block & all attributes.
Thanks for the comformation.  I had thought this, but wasn't sure.
FWIW, this may be a viable option for what your concerns were: "I like the fact of title blocks being xrefs, but I don't like having so much loose text associated with them, this way one could have an xref'ed title block with attributes". Why not use an Xref for all static portions of the Title Block and use a standard block w/attributes for the "loose" text/attributes? This way your Title block is composed of 2 objects (which you could Group together).
I have used this in the past.  The problems is that it can be moved by someone, so that they are not lined up anymore.  I have done this, and have made it easy to use, but they still get messed up, and the only time you see it is when it is already plotted.  This was an idea so that you won't have that problem at all.

This was a fun exercise for me.  I can never seem to get entmake to work for me, so I wanted to see if I could.  Too bad it can't be done with ActiveX controls, that would have been fun to try also.

Thanks everyone for the contributions, code and knowledge.  It was a great learning experience for me.
Title: Re: Add attributes one the fly
Post by: LE on December 14, 2005, 03:01:28 PM
Should I remove all the code samples [I posted]... since they do not apply here ?

Thanks.
Title: Re: Add attributes one the fly
Post by: T.Willey on December 14, 2005, 03:08:20 PM
Should I remove all the code samples [I posted]... since they do not apply here ?

Thanks.

I would say no because maybe someone searching could use them.  But that is just me.  It makes good reading.
Title: Re: Add attributes one the fly
Post by: T.Willey 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)
)
Title: Re: Add attributes one the fly
Post by: T.Willey 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)
)
Title: Re: Add attributes one the fly
Post by: T.Willey 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)
)
Title: Re: Add attributes one the fly
Post by: chlh_jd 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" .
Title: Re: Add attributes one the fly
Post by: T.Willey 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.
Title: Re: Add attributes one the fly
Post by: Hugo 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