Topic: Mapping normal block attributes to many block instances

[adalea03]

I've long used specific routines for specific blocks with block names and tagstrings hard coded.
This single routine replaces several of the others by by presenting attribute data in a dialog on the fly.
Nothing new, I know, but the dialog allows you to toggle the attributes that you want to map to other instances of the block.

Code: [Select]

;;;   ATTMAP.LSP                                                                                       
;;;   Without reinventing the wheel, I've added a re-tread for better milaage...                       
;;;                                                                                                     
;;; Thanks to AfraLisp.com and the Swamp.org                                                         
;;; The code is mostly a 're-tooling' of DCLATT.LSP Written by Kenny Ramage & Stig Madsen - May 2002 
;;; Most of the subroutines are examples of Ken & Stig's fine work and in their original form.       
;;;   A clip of the disclaimer follows:                                                                 
;;;                                                                                                     
;;;   " All Tutorials and Code are provided "as-is" for purposes of instruction and                     
;;;   utility and may be used by anyone for any purpose entirely at their own risk.                     
;;;   Please respect the intellectual rights of others.                                                 
;;;   All material provided here is unsupported and without warranty of any kind.                       
;;;   No responsibility will be taken for any direct or indirect consequences                           
;;;   resulting from or associated with the use of these Tutorials or Code.                             
;;;                                                                                                     
;;;                    AfraLisp                                                                 
;;;                http://www.afralisp.com                                                         
;;;                 afralisp@afralisp.com                                                         
;;;                  afralisp@mweb.com.na "                                                         
;;;                                                                                                     
;;; I have only modified enough to provide for mapping selected atts to blocks with like atts.       
;;; Purpose:                                                                                         
;;; Edit the att vals of a block then map selected att vals to blocks having like atts.           
;;; Useful when many blocks need att vals revised to the same value.                               
;;; Notes:  
;;; Error checking = nil     
;;; A directory path: "C:\Temp" is necessary for writing and invoking the temporary dcl file.     
;;; The dialog is made on the fly by mapping the att info of the source block to a temp dcl file. 
;;; So, this should work with any normal attributed block (well, so far, anyway) notwithstanding...
;;; The number of atts displayed in the dialog box will be subject to hardware limitations.       
;;; I have been successful with 18 thus far. I haven't had need for more.                         
;;; The temp dcl file is deleted upon exiting the dialog box.                                     
;;; Usage:                                                                                           
;;; Load the routine from a search path by typing (load "ATTMAP") at the command prompt.           
;;; Enter "attmap" on the commandline.                                                             
;;; Select a "source" block (i.e. the block which will be used to provide the att tags/vals).     
;;; A dialog box, listing the available atts, will be invoked.                                     
;;; Edit the values as desired.                                                                   
;;; If no mapping is desired, select the "OK" button to exit the dialog box.                       
;;; The "source" block will be updated with the att vals of the dialog box.                     
;;; If mapping is desired, toggle the desired atts to "ON" in the dialog box.                     
;;; Select the "OK" button to exit the dialog box.                                             
;;; You will be promted (at the commandline) to select the target blocks for mapping.           
;;; Use any selection method you like to select blocks with like atts.                         
;;; The selection set will be filtered for "INSERTS" that have attributes.                     
;;; Each member of the sset with like atts                                                     
;;; will be updated with the toggled att vals of the dialog box.                             
;;;                                                                                                     
;;;   With additional thanks to:                                                                       
;;;    The Swamp.org >  99% of my programming inspiration comes from there.                             
;;;                                                                                                     
;;;   Permissions:                                                                                     
;;;   All are free to use, modify..etc.                                                                 
;;;                                                                                                     
;;;   Platforms:                                                                                       
;;; I am limited to ADT 3.3 on Acad 2002 at work, so, most of my routines are written accordingly.   
;;; Tested on Acad 2002,only.                                                                         
;;;                                                                                                     
;;; Version:                                                                                           
;;; 1.0  -  01.03.10  - FIRST RELEASE                                                                   
;;; 2.0  -            -                                                                                 
;;; 3.0  -            -                                                                                 
;;;=====================================================================================================

(defun c:attmap (/ atts2map cntr dcl_id dlg-vals fn fname indx key-lst l lg map-targs nu relist
                   taglist targs-ss tggls tg-lst theblock theblocko thelist trgnam txtlist x y z)
  ;start fresh by clearing possible values from required variables                                     
  (foreach xi '(atts2map cntr dcl_id dlg-vals fn fname indx key-lst l lg map-targs nu
                relist taglist targs-ss tggls tg-lst theblock theblocko thelist trgnam
                txtlist x y z) (set xi nil))
  (vl-load-com)
  (setq theblock (car (entsel)))                        ;get the source block entity name
  (setq theblockO (vlax-ename->vla-object theblock))    ;convert to vl object
  (if (= (vlax-get-property theblockO 'objectname) "AcDbBlockReference")
    ;check if it's a block; if it is, do the following
    (progn
      (if (= (vlax-get-property theblockO 'hasattributes) :vlax-true)
        ;check if it has attributes ;if it has attributes, do the following             
        (progn                                                       
          (getattmap theblockO)  ;get the attributes                                     
          (create_attmap_dialog) ;create the dialog                                     
          (run_attmap_dialog)    ;run the dialog                                         
          (upattmap))            ;update the attributes ;if No attributes, alert the user
        (alert "This Block has No Attributes!! - Please try again.")))
    (alert "This is not a Block!! - Please try again.")) ;if it's not a block, alert the user
  ;if atts were toggled in the dialog box,                                                   
  ; map the selected attributes to the selected blocks                                       
  (if atts2map
    (progn (setq map-targs nil targs-ss nil)
      (setq targs-ss (ssget '((0 . "INSERT") (66 . 1))))
      (setq indx 0)
      (while (setq trgnam (ssname targs-ss indx))
        (setq map-targs (append map-targs (list trgnam)))
        (setq indx (1+ indx)))
      (foreach xi map-targs
        (foreach ix atts2map (matt_putone xi (car ix) (strcase (cadr ix))))))
    (princ "\n  No atts were selected for mapping."))
  (princ))

;;;=================   edit one attribute   ==========================================
(defun matt_putone  (en tag new / el) ; variables are cleared in the main routine     
  (setq en (entnext en) el (entget en))
  (while
    (and (= (cdr (assoc 0 el)) "ATTRIB") (/= (cdr (assoc 2 el)) tag))
     (setq en (entnext en) el (entget en)))
  (if (= (cdr (assoc 0 el)) "ATTRIB")
    (progn (entmod (subst (cons 1 new) (assoc 1 el) el)) (entupd en))))

;retrieve the attributes
  (defun getattmap (enam /) ; variables are cleared in the main routine               
    (setq thelist (vlax-safearray->list (variant-value (vla-getattributes enam))))
    (foreach n thelist                                    ;process each attribute     
      (setq taglist (cons (vla-get-tagstring n) taglist)  ;get the tag attribute data
            txtlist (cons (vla-get-textstring n) txtlist) ;get the text attribute data
            lg      (length taglist)))                    ;how many attributes?       
    (setq taglist (reverse taglist)                       ;reverse the lists         
          txtlist (reverse txtlist))
       (setq tg-lst (mapcar '(lambda (x y z) (list x y z)) tggls taglist txtlist)))

(defun create_attmap_dialog ()        ; variables are cleared in the main routine     
  (setq fname "c:\\temp\\attmap.dcl") ;create a temp DCL file                         
  (setq fn (open fname "w"))         ;open it to write                               
                                         ;write the dialog header                       
  (write-line "attmap:dialog { label = \"Edit/Map Attributes\";" fn)
  (setq nu 0)                         ;reset the incremental control number           
  (repeat lg                          ;start the loop to create the edit boxes       
    (write-line
         (strcat ":row {" ":toggle {" (strcat "key=\"tg" (itoa nu) "\";}") " :edit_box {"
        (strcat " key=" (strcat "\"" "eb" (itoa nu) "\"" ";"))
           (strcat " label=" "\"" (nth nu taglist) "\"" ";")
        (strcat " value = " "\"" (nth nu txtlist) "\"" ";")
           " alignment=left; edit_width=30;}" "}") fn)
    (setq nu (1+ nu)))                ;increment the counter                         
  (write-line ":row {spacer_1;}" fn)
  (write-line ":row {spacer_1; ok_only; spacer_1;}}" fn)
  (close fn))                         ;close the internal file                       

;load the dialog file and definition                                                 
(defun run_attmap_dialog  (); variables are cleared in the main routine               
  (setq key-lst nil dlg-vals nil)
     (defun get-dlg-vals  () ;subroutine to get all dialog vals                       
       (setq cntr 0 key-lst nil)
       (repeat lg
         (setq key-lst (append key-lst (list
              (list (strcat "tg" (itoa cntr)) (strcat "eb" (itoa cntr))))))
         (setq cntr (1+ cntr)))
       (setq cntr 0 dlg-vals nil)
       (foreach xi key-lst
         (setq dlg-vals (append dlg-vals (list (list
                 (car xi) (strcase (get_tile (car xi)))
                 (get_attr (cadr xi) "label") (get_tile (cadr xi)))))))
       (setq cntr 0 atts2map nil)
       (foreach xi dlg-vals
         (if (= (cadr xi) "1")
           (setq atts2map (append atts2map (list (list (caddr xi) (last xi))))) nil))
       );end sub
     
  (setq dcl_id (load_dialog fname))
  (mode_tile "eb0" 2)
  (if (not (new_dialog "attmap" dcl_id)) (exit))
  (action_tile "accept" "(get-dlg-vals)(retattmap)") ;if the OK button is selected   
  (start_dialog)          ;start the dialog                                           
  (unload_dialog dcl_id)  ;unload the dialog                                         
  (vl-file-delete fname)) ;delete the temp DCL file                                   

(defun retattmap  () ; variables are cleared in the main routine                     
  (setq nu 0)        ;reset the increment counter                                     
  (repeat lg         ;start the loop                                                 
    (setq l (get_tile (strcat "eb" (itoa nu)))) ;retrieve the tile value             
    (setq relist (cons l relist))               ;add it to the list                   
    (setq nu (1+ nu)))                          ;increment the counter               
  (setq relist (reverse relist))
  (done_dialog))

(defun upattmap  ()  ; variables are cleared in the main routine                         
  (setq nu 0)       ;reset the increment counter                                       
  (repeat lg       ;start the loop                                                     
    (vla-put-textstring (nth nu thelist) (strcase (nth nu relist))) ;update the attribute
    (setq nu (1+ nu)))   ;increment the counter                                         
  (vla-update theblockO)) ;update the block                                             
;;;   end                                                                                   

[CAB]

Congrats on your 100th post! 

Code looks nice, off to give it a test drive..

[CAB]

Some comments:
The block Name is not displayed.

If the tag names are duplicated & selection set is made the original block
has both the attributes with the same tag updated where the other inserts have only
the first matching tag found updated.

If the user hits ENTER when asked to select Objects the routine crashes.


Have you had a look at this one? http://www.theswamp.org/index.php?topic=10216.0

[adalea03]

Thanks for your respected reply, Cab.
In retrospect:
  1. Chuuuuuuuuuute.
  2. Chuuuuuuuuuute.
  3. Chuuuuuuuuuute.

Tha fact that tagstrings may be duplicated is something that I use as an advatantage; of course the purpose and design of the block atts and the routine
will only harmonize successfully if it is planned that way . (Doesn't everybody?)

I use attributed blocks that are closely related somewhat similar to relationships in a database.
When they represent the same indididual product, the appropriate atts will have the same tagstrings.
Thus mapping from overall plan dwgs to to individual productin dwgs is far less tedious; and mapping from production dwgs to BOMS is far less...

But most importantly, I agree with you, that this could be made more universally effective.

When I read that you CRASHED it, I took the sheath from John Belushi's Samuri sword and...
 ... Luckily, noticed that you posted a link to a thread from 2006 that I should have seen (prolly did)
, butdidn't  capitilzed on it ...so I took the sheath from John Belushi's Samuri sword ...

So, I'll work on the crashing and the display of the block name, but please , no fish.
Rancid, stinky bait may prove enough to fill the net.

Thanks again for your observations.

Tony

[CAB]

I'm sure you can Iron out the wrinkles. 

[adalea03]

Work load just doubled, bit I'm hacking at it.
AA

[adalea03]

I have fixed the crashing, but I prolly won't develope this project any further.
After test driving  the one CAB provided, I liked his better.
Thanks for your earlier testing and comments, CAB.
I'm off to new challenges.

Code: [Select]

;;;   ATTMAP.LSP                                                                                       
;;;   Without reinventing the wheel, I've added a re-tread for better milaage...                       
;;;                                                                                                     
;;; Thanks to AfraLisp.com and the Swamp.org                                                         
;;; The code is mostly a 're-tooling' of DCLATT.LSP Written by Kenny Ramage & Stig Madsen - May 2002 
;;; Most of the subroutines are examples of Ken & Stig's fine work and in their original form.       
;;;   A clip of the disclaimer follows:                                                                 
;;;                                                                                                     
;;;   " All Tutorials and Code are provided "as-is" for purposes of instruction and                     
;;;   utility and may be used by anyone for any purpose entirely at their own risk.                     
;;;   Please respect the intellectual rights of others.                                                 
;;;   All material provided here is unsupported and without warranty of any kind.                       
;;;   No responsibility will be taken for any direct or indirect consequences                           
;;;   resulting from or associated with the use of these Tutorials or Code.                             
;;;                                                                                                     
;;;                    AfraLisp                                                                 
;;;                http://www.afralisp.com                                                         
;;;                 afralisp@afralisp.com                                                         
;;;                  afralisp@mweb.com.na "                                                         
;;;                                                                                                     
;;; I have only modified enough to provide for mapping selected atts to blocks with like atts.       
;;; Purpose:                                                                                         
;;; Edit the att vals of a block then map selected att vals to blocks having like atts.           
;;; Useful when many blocks need att vals revised to the same value.                               
;;; Notes:  
;;; Error checking = nil     
;;; A directory path: "C:\Temp" is necessary for writing and invoking the temporary dcl file.     
;;; The dialog is made on the fly by mapping the att info of the source block to a temp dcl file. 
;;; So, this should work with any normal attributed block (well, so far, anyway) notwithstanding...
;;; The number of atts displayed in the dialog box will be subject to hardware limitations.       
;;; I have been successful with 18 thus far. I haven't had need for more.                         
;;; The temp dcl file is deleted upon exiting the dialog box.                                     
;;; Usage:                                                                                           
;;; Load the routine from a search path by typing (load "ATTMAP") at the command prompt.           
;;; Enter "attmap" on the commandline.                                                             
;;; Select a "source" block (i.e. the block which will be used to provide the att tags/vals).     
;;; A dialog box, listing the available atts, will be invoked.                                     
;;; Edit the values as desired.                                                                   
;;; If no mapping is desired, select the "OK" button to exit the dialog box.                       
;;; The "source" block will be updated with the att vals of the dialog box.                     
;;; If mapping is desired, toggle the desired atts to "ON" in the dialog box.                     
;;; Select the "OK" button to exit the dialog box.                                             
;;; You will be promted (at the commandline) to select the target blocks for mapping.           
;;; Use any selection method you like to select blocks with like atts.                         
;;; The selection set will be filtered for "INSERTS" that have attributes.                     
;;; Each member of the sset with like atts                                                     
;;; will be updated with the toggled att vals of the dialog box.                             
;;;                                                                                                     
;;;   With additional thanks to:                                                                       
;;;    The Swamp.org >  99% of my programming inspiration comes from there.                             
;;;                                                                                                     
;;;   Permissions:                                                                                     
;;;   All are free to use, modify..etc.                                                                 
;;;                                                                                                     
;;;   Platforms:                                                                                       
;;; I am limited to ADT 3.3 on Acad 2002 at work, so, most of my routines are written accordingly.   
;;; Tested on Acad 2002,only.                                                                         
;;;                                                                                                     
;;; Version:                                                                                           
;;; 1.0  -  01.03.10  - first release                                                                   
;;; 2.0  -  01.11.10  - fixed crashing when source block or target blocks are not selected             
;;; 3.0  -            -                                                                                 
;;;=====================================================================================================

(defun c:attmap (/ *error* atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l
                   lg map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                   thelist thename trgnam txtlist x y z)
  (defun *error* (msg) ; Error Handler by Columbia at theswamp.org
    (if (not (member msg '("quit / exit abort" "function cancelled" "console break")))
      (princ "\nError: " msg))
;;;    opt'l method
;;;      (if (or (= msg "Function cancelled") (= msg "quit / exit abort"))
;;;        (princ) (princ (strcat "\nError: " msg))) ;;
    (command)
    (command) ; cancels any command in progress
;;;  reset any environment variables or close out any file objects or terminate any dialogs here...
    (princ))
;;;  ... the rest of your app goes here ...
 
  ;start fresh by clearing possible values from required variables                                     
  (foreach xi '(atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l lg
                map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                thelist trgnam thename txtlist x y z) (set xi nil))
;|  (list atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l lg
                map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                thelist trgnam thename txtlist x y z)
                |;
  (vl-load-com)
  (setq theblock nil)
  (while (not theblock)
    (progn
      (setq ent (car (entsel "\n Select a source block...")))  ;get the source block entity name
      (if (and ent
               (= (cdr (assoc 0 (setq elst (entget ent)))) "INSERT")
               (setq theblockO (vlax-ename->vla-object ent))    ;convert to vl object
               (= (vlax-get-property theblockO 'objectname) "AcDbBlockReference")
               (= (vlax-get-property theblockO 'hasattributes) :vlax-true))
        (setq theblock ent
              thename (cdr (assoc 2 elst)))
        (progn
          (if theblockO (vlax-release-object theblockO))
          (prompt "\n No attributed block selected; Try again...")
          (setq theblock nil ent nil theblockO nil thename nil)))))

  (if (and theblock ent theblocko thename)
    (progn (getattmap theblocko)  ;get the attributes and                                 
           (create_attmap_dialog) ;create the dialog and                                 
           (run_attmap_dialog)    ;run the dialog and                                     
           (upattmap))            ;update the attributes ; or alert the user             
    (alert (strcat "Either this is not a Block,"  ;if it's not a block, alert the user   
             "\nOr, this Block has No Attributes.\nPlease try again.")))
  ;if atts were toggled in the dialog box,                                                   
  ; map the selected attributes to the selected blocks                                       
  (if atts2map
    (progn (setq map-targs nil targs-ss nil)
      (prompt "\n Selected target blocks for mapping...")
      (setq targs-ss (ssget (list (cons 2 thename) '(0 . "INSERT")  '(66 . 1))))
      (if targs-ss
        (progn (setq indx 0)
               (while (setq trgnam (ssname targs-ss indx))
                 (setq map-targs (append map-targs (list trgnam)))
                 (setq indx (1+ indx)))
               (foreach xi  map-targs
                 (foreach ix atts2map (matt_putone xi (car ix) (strcase (cadr ix))))))
        (prompt "\n  No blocks were selected for mapping.")))
    (princ "\n  No atts were selected for mapping."))
  (princ))

;;;=================   edit one attribute   ==========================================
(defun matt_putone  (en tag new / el) ; variables are cleared in the main routine     
  (setq en (entnext en) el (entget en))
  (while
    (and (= (cdr (assoc 0 el)) "ATTRIB") (/= (cdr (assoc 2 el)) tag))
     (setq en (entnext en) el (entget en)))
  (if (= (cdr (assoc 0 el)) "ATTRIB")
    (progn (entmod (subst (cons 1 new) (assoc 1 el) el)) (entupd en))))

;retrieve the attributes
  (defun getattmap (enam /) ; variables are cleared in the main routine               
    (setq thelist (vlax-safearray->list (variant-value (vla-getattributes enam))))
    (foreach n thelist                                    ;process each attribute     
      (setq taglist (cons (vla-get-tagstring n) taglist)  ;get the tag attribute data
            txtlist (cons (vla-get-textstring n) txtlist) ;get the text attribute data
            lg      (length taglist)))                    ;how many attributes?       
    (setq taglist (reverse taglist)                       ;reverse the lists         
          txtlist (reverse txtlist))
       (setq tg-lst (mapcar '(lambda (x y z) (list x y z)) tggls taglist txtlist)))

(defun create_attmap_dialog ()        ; variables are cleared in the main routine     
  (setq fname "c:\\temp\\attmap.dcl") ;create a temp DCL file                         
  (setq fn (open fname "w"))         ;open it to write                               
                                         ;write the dialog header                       
  (write-line "attmap:dialog { label = \"Edit/Map Attributes\";" fn)
  (setq nu 0)                         ;reset the incremental control number           
  (repeat lg                          ;start the loop to create the edit boxes       
    (write-line
         (strcat ":row {" ":toggle {" (strcat "key=\"tg" (itoa nu) "\";}") " :edit_box {"
        (strcat " key=" (strcat "\"" "eb" (itoa nu) "\"" ";"))
           (strcat " label=" "\"" (nth nu taglist) "\"" ";")
        (strcat " value = " "\"" (nth nu txtlist) "\"" ";")
           " alignment=left; edit_width=30;}" "}") fn)
    (setq nu (1+ nu)))                ;increment the counter                         
  (write-line ":row {spacer_1;}" fn)
  (write-line ":row {spacer_1; ok_only; spacer_1;}}" fn)
  (close fn))                         ;close the internal file                       

;load the dialog file and definition                                                 
(defun run_attmap_dialog  (); variables are cleared in the main routine               
  (setq key-lst nil dlg-vals nil)
     (defun get-dlg-vals  () ;subroutine to get all dialog vals                       
       (setq cntr 0 key-lst nil)
       (repeat lg
         (setq key-lst (append key-lst (list
              (list (strcat "tg" (itoa cntr)) (strcat "eb" (itoa cntr))))))
         (setq cntr (1+ cntr)))
       (setq cntr 0 dlg-vals nil)
       (foreach xi key-lst
         (setq dlg-vals (append dlg-vals (list (list
                 (car xi) (strcase (get_tile (car xi)))
                 (get_attr (cadr xi) "label") (get_tile (cadr xi)))))))
       (setq cntr 0 atts2map nil)
       (foreach xi dlg-vals
         (if (= (cadr xi) "1")
           (setq atts2map (append atts2map (list (list (caddr xi) (last xi))))) nil))
       );end sub
     
  (setq dcl_id (load_dialog fname))
  (mode_tile "eb0" 2)
  (if (not (new_dialog "attmap" dcl_id)) (exit))
  (action_tile "accept" "(get-dlg-vals)(retattmap)") ;if the OK button is selected   
  (start_dialog)          ;start the dialog                                           
  (unload_dialog dcl_id)  ;unload the dialog                                         
  (vl-file-delete fname)) ;delete the temp DCL file                                   

(defun retattmap  () ; variables are cleared in the main routine                     
  (setq nu 0)        ;reset the increment counter                                     
  (repeat lg         ;start the loop                                                 
    (setq l (get_tile (strcat "eb" (itoa nu)))) ;retrieve the tile value             
    (setq relist (cons l relist))               ;add it to the list                   
    (setq nu (1+ nu)))                          ;increment the counter               
  (setq relist (reverse relist))
  (done_dialog))

(defun upattmap  ()  ; variables are cleared in the main routine                         
  (setq nu 0)       ;reset the increment counter                                       
  (repeat lg       ;start the loop                                                     
    (vla-put-textstring (nth nu thelist) (strcase (nth nu relist))) ;update the attribute
    (setq nu (1+ nu)))   ;increment the counter                                         
  (vla-update theblockO)) ;update the block                                             
;;;   end                                                                                   

[adalea03]

No, really, I'm done.
I just forgot to display the block name in the earlier post.

Code: [Select]

;;;   ATTMAP.LSP                                                                                       
;;;   Without reinventing the wheel, I've added a re-tread for better milaage...                       
;;;                                                                                                     
;;; Thanks to AfraLisp.com and the Swamp.org                                                         
;;; The code is mostly a 're-tooling' of DCLATT.LSP Written by Kenny Ramage & Stig Madsen - May 2002 
;;; Most of the subroutines are examples of Ken & Stig's fine work and in their original form.       
;;;   A clip of the disclaimer follows:                                                                 
;;;                                                                                                     
;;;   " All Tutorials and Code are provided "as-is" for purposes of instruction and                     
;;;   utility and may be used by anyone for any purpose entirely at their own risk.                     
;;;   Please respect the intellectual rights of others.                                                 
;;;   All material provided here is unsupported and without warranty of any kind.                       
;;;   No responsibility will be taken for any direct or indirect consequences                           
;;;   resulting from or associated with the use of these Tutorials or Code.                             
;;;                                                                                                     
;;;                    AfraLisp                                                                 
;;;                http://www.afralisp.com                                                         
;;;                 afralisp@afralisp.com                                                         
;;;                  afralisp@mweb.com.na "                                                         
;;;                                                                                                     
;;; I have only modified enough to provide for mapping selected atts to blocks with like atts.       
;;; Purpose:                                                                                         
;;; Edit the att vals of a block then map selected att vals to blocks having like atts.           
;;; Useful when many blocks need att vals revised to the same value.                               
;;; Notes:  
;;; Error checking = nil     
;;; A directory path: "C:\Temp" is necessary for writing and invoking the temporary dcl file.     
;;; The dialog is made on the fly by mapping the att info of the source block to a temp dcl file. 
;;; So, this should work with any normal attributed block (well, so far, anyway) notwithstanding...
;;; The number of atts displayed in the dialog box will be subject to hardware limitations.       
;;; I have been successful with 18 thus far. I haven't had need for more.                         
;;; The temp dcl file is deleted upon exiting the dialog box.                                     
;;; Usage:                                                                                           
;;; Load the routine from a search path by typing (load "ATTMAP") at the command prompt.           
;;; Enter "attmap" on the commandline.                                                             
;;; Select a "source" block (i.e. the block which will be used to provide the att tags/vals).     
;;; A dialog box, listing the available atts, will be invoked.                                     
;;; Edit the values as desired.                                                                   
;;; If no mapping is desired, select the "OK" button to exit the dialog box.                       
;;; The "source" block will be updated with the att vals of the dialog box.                     
;;; If mapping is desired, toggle the desired atts to "ON" in the dialog box.                     
;;; Select the "OK" button to exit the dialog box.                                             
;;; You will be promted (at the commandline) to select the target blocks for mapping.           
;;; Use any selection method you like to select blocks with like atts.                         
;;; The selection set will be filtered for "INSERTS" that have attributes.                     
;;; Each member of the sset with like atts                                                     
;;; will be updated with the toggled att vals of the dialog box.                             
;;;                                                                                                     
;;;   With additional thanks to:                                                                       
;;;    The Swamp.org >  99% of my programming inspiration comes from there.                             
;;;                                                                                                     
;;;   Permissions:                                                                                     
;;;   All are free to use, modify..etc.                                                                 
;;;                                                                                                     
;;;   Platforms:                                                                                       
;;; I am limited to ADT 3.3 on Acad 2002 at work, so, most of my routines are written accordingly.   
;;; Tested on Acad 2002,only.                                                                         
;;;                                                                                                     
;;; Version:                                                                                           
;;; 1.0  -  01.03.10  - first release                                                                   
;;; 2.0  -  01.11.10  - fixed crashing when source block or target blocks are not selected             
;;; 3.0  -            -                                                                                 
;;;=====================================================================================================

(defun c:attmap (/ *error* atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l
                   lg map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                   thelist thename trgnam txtlist x y z)
  (defun *error* (msg) ; Error Handler by Columbia at theswamp.org
    (if (not (member msg '("quit / exit abort" "function cancelled" "console break")))
      (princ "\nError: " msg))
;;;    opt'l method
;;;      (if (or (= msg "Function cancelled") (= msg "quit / exit abort"))
;;;        (princ) (princ (strcat "\nError: " msg))) ;;
    (command)
    (command) ; cancels any command in progress
;;;  reset any environment variables or close out any file objects or terminate any dialogs here...
    (princ))
;;;  ... the rest of your app goes here ...
 
  ;start fresh by clearing possible values from required variables                                     
  (foreach xi '(atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l lg
                map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                thelist trgnam thename txtlist x y z) (set xi nil))
;|  (list atts2map cntr dcl_id dlg-vals ent elst fn fname indx key-lst l lg
                map-targs nu relist taglist targs-ss tggls tg-lst theblock theblocko
                thelist trgnam thename txtlist x y z)
                |;
  (vl-load-com)
  (setq theblock nil)
  (while (not theblock)
    (progn
      (setq ent (car (entsel "\n Select a source block...")))  ;get the source block entity name
      (if (and ent
               (= (cdr (assoc 0 (setq elst (entget ent)))) "INSERT")
               (setq theblockO (vlax-ename->vla-object ent))    ;convert to vl object
               (= (vlax-get-property theblockO 'objectname) "AcDbBlockReference")
               (= (vlax-get-property theblockO 'hasattributes) :vlax-true))
        (setq theblock ent
              thename (cdr (assoc 2 elst)))
        (progn
          (if theblockO (vlax-release-object theblockO))
          (prompt "\n No attributed block selected; Try again...")
          (setq theblock nil ent nil theblockO nil thename nil)))))

  (if (and theblock ent theblocko thename)
    (progn (getattmap theblocko)  ;get the attributes and                                 
           (create_attmap_dialog) ;create the dialog and                                 
           (run_attmap_dialog)    ;run the dialog and                                     
           (upattmap))            ;update the attributes ; or alert the user             
    (alert (strcat "Either this is not a Block,"  ;if it's not a block, alert the user   
             "\nOr, this Block has No Attributes.\nPlease try again.")))
  ;if atts were toggled in the dialog box,                                                   
  ; map the selected attributes to the selected blocks                                       
  (if atts2map
    (progn (setq map-targs nil targs-ss nil)
      (prompt "\n Selected target blocks for mapping...")
      (setq targs-ss (ssget (list (cons 2 thename) '(0 . "INSERT")  '(66 . 1))))
      (if targs-ss
        (progn (setq indx 0)
               (while (setq trgnam (ssname targs-ss indx))
                 (setq map-targs (append map-targs (list trgnam)))
                 (setq indx (1+ indx)))
               (foreach xi  map-targs
                 (foreach ix atts2map (matt_putone xi (car ix) (strcase (cadr ix))))))
        (prompt "\n  No blocks were selected for mapping.")))
    (princ "\n  No atts were selected for mapping."))
  (princ))

;;;=================   edit one attribute   ==========================================
(defun matt_putone  (en tag new / el) ; variables are cleared in the main routine     
  (setq en (entnext en) el (entget en))
  (while
    (and (= (cdr (assoc 0 el)) "ATTRIB") (/= (cdr (assoc 2 el)) tag))
     (setq en (entnext en) el (entget en)))
  (if (= (cdr (assoc 0 el)) "ATTRIB")
    (progn (entmod (subst (cons 1 new) (assoc 1 el) el)) (entupd en))))

;retrieve the attributes
  (defun getattmap (enam /) ; variables are cleared in the main routine               
    (setq thelist (vlax-safearray->list (variant-value (vla-getattributes enam))))
    (foreach n thelist                                    ;process each attribute     
      (setq taglist (cons (vla-get-tagstring n) taglist)  ;get the tag attribute data
            txtlist (cons (vla-get-textstring n) txtlist) ;get the text attribute data
            lg      (length taglist)))                    ;how many attributes?       
    (setq taglist (reverse taglist)                       ;reverse the lists         
          txtlist (reverse txtlist))
       (setq tg-lst (mapcar '(lambda (x y z) (list x y z)) tggls taglist txtlist)))

(defun create_attmap_dialog ()        ; variables are cleared in the main routine     
  (setq fname "c:\\temp\\attmap.dcl") ;create a temp DCL file                         
  (setq fn (open fname "w"))         ;open it to write                               
                                         ;write the dialog header                       
  (write-line "attmap:dialog { label = \"Edit/Map Attributes\";" fn)
     (write-line
    ":row {alignment=centered;
     :text {key=\"tb0\"; value=\"Block Name :  \";}
     :text {key=\"bname\"; value=\"Block Name Goes Here\";}spacer_1;}" fn)

     
  (setq nu 0)                         ;reset the incremental control number           
  (repeat lg                          ;start the loop to create the edit boxes       
    (write-line
         (strcat ":row {" ":toggle {" (strcat "key=\"tg" (itoa nu) "\";}") " :edit_box {"
        (strcat " key=" (strcat "\"" "eb" (itoa nu) "\"" ";"))
           (strcat " label=" "\"" (nth nu taglist) "\"" ";")
        (strcat " value = " "\"" (nth nu txtlist) "\"" ";")
           " alignment=left; edit_width=30;}" "}") fn)
    (setq nu (1+ nu)))                ;increment the counter                         
  (write-line ":row {spacer_1;}" fn)
  (write-line ":row {spacer_1; ok_only; spacer_1;}}" fn)
  (close fn))                         ;close the internal file                       

;load the dialog file and definition                                                 
(defun run_attmap_dialog  (); variables are cleared in the main routine               
  (setq key-lst nil dlg-vals nil)
     (defun get-dlg-vals  () ;subroutine to get all dialog vals                       
       (setq cntr 0 key-lst nil)
       (repeat lg
         (setq key-lst (append key-lst (list
              (list (strcat "tg" (itoa cntr)) (strcat "eb" (itoa cntr))))))
         (setq cntr (1+ cntr)))
       (setq cntr 0 dlg-vals nil)
       (foreach xi key-lst
         (setq dlg-vals (append dlg-vals (list (list
                 (car xi) (strcase (get_tile (car xi)))
                 (get_attr (cadr xi) "label") (get_tile (cadr xi)))))))
       (setq cntr 0 atts2map nil)
       (foreach xi dlg-vals
         (if (= (cadr xi) "1")
           (setq atts2map (append atts2map (list (list (caddr xi) (last xi))))) nil))
       );end sub
     
  (setq dcl_id (load_dialog fname))
  (mode_tile "eb0" 2)
  (if (not (new_dialog "attmap" dcl_id)) (exit))
     (set_tile "bname" (strcase thename))
     
  (action_tile "accept" "(get-dlg-vals)(retattmap)") ;if the OK button is selected   
  (start_dialog)          ;start the dialog                                           
  (unload_dialog dcl_id)  ;unload the dialog                                         
  (vl-file-delete fname)) ;delete the temp DCL file                                   

(defun retattmap  () ; variables are cleared in the main routine                     
  (setq nu 0)        ;reset the increment counter                                     
  (repeat lg         ;start the loop                                                 
    (setq l (get_tile (strcat "eb" (itoa nu)))) ;retrieve the tile value             
    (setq relist (cons l relist))               ;add it to the list                   
    (setq nu (1+ nu)))                          ;increment the counter               
  (setq relist (reverse relist))
  (done_dialog))

(defun upattmap  ()  ; variables are cleared in the main routine                         
  (setq nu 0)       ;reset the increment counter                                       
  (repeat lg       ;start the loop                                                     
    (vla-put-textstring (nth nu thelist) (strcase (nth nu relist))) ;update the attribute
    (setq nu (1+ nu)))   ;increment the counter                                         
  (vla-update theblockO)) ;update the block                                             
;;;   end