;;; Rename Attributes by Irné Barnard ;;; Version 3 (vl-load-com) (defun RenAtt:LoadSettings (filename / f s lst) (if (and (or (setq f (findfile (cond (filename) ("RenAttrib.DAT")))) (setq f (findfile (strcat (getvar "RoamableRootPrefix") "RenAttrib.DAT")))) (setq f (open f "r"))) (progn (setq lst "") (while (setq s (read-line f)) (setq lst (strcat lst "\n" s))) (setq lst (read lst)) (close f))) (setq *RenAtt:Settings* lst)) (RenAtt:LoadSettings nil) (defun RenAtt:SaveSettings (filename / f) (setq f (cond (filename) ((findfile "RenAttrib.DAT")) ((strcat (getvar "RoamableRootPrefix") "RenAttrib.DAT")))) (if (setq f (open f "w")) (progn (prin1 *RenAtt:Settings* f) (close f)))) ;; Get ALL (even duplicate) attributes from a block reference (defun RenAtt:GetAttributes (obj / an ao lst) (setq an (vlax-vla-object->ename obj)) (while (and (setq an (entnext an)) (setq ao (vlax-ename->vla-object an)) (eq (vla-get-ObjectName ao) "AcDbAttribute")) (setq lst (cons ao lst))) lst) (defun RenAtt:GetBlocks (/ lst item name attList attTest attName changed) (or *AcadApp* (setq *AcadApp* (vlax-get-acad-object))) (or *ActiveDocument* (setq *ActiveDocument* (vla-get-ActiveDocument *AcadApp*))) (or *BlocksCollection* (setq *BlocksCollection* (vla-get-Blocks *ActiveDocument*))) ;; Get attributes from block definitions (vlax-for blk *BlocksCollection* (if (wcmatch (setq name (vla-get-Name blk)) "~`**") (progn (setq item nil) (vlax-for obj blk (if (eq (vla-get-ObjectName obj) "AcDbAttributeDefinition") (if (setq attTest (assoc (setq attName (strcase (vla-get-TagString obj))) item)) (setq item (subst (cons attName (1+ (cdr attTest))) attTest item)) (setq item (cons (cons attName 1) item))))) (if item (setq lst (cons (cons (strcase name) (reverse item)) lst)))))) ;; Get attributes from block references (vlax-for blk *BlocksCollection* (vlax-for obj blk (if (and (eq (vla-get-ObjectName obj) "AcDbBlockReference") (eq (vla-get-HasAttributes obj) :vlax-true)) (progn (setq attList nil) (foreach att (vlax-invoke obj "GetAttributes") (if (and (setq attName (strcase (vla-get-TagString att))) (setq attTest (assoc attName attList))) (setq attList (subst (cons attName (1+ (cdr attTest))) attTest attList)) (setq attList (cons (cons attName 1) attList)))) (setq name (strcase (vla-get-EffectiveName obj)) item (reverse (cdr (assoc name lst))) attName nil) (foreach att (reverse attList) (if (setq attTest (assoc (setq attName (car att)) item)) (if (> (cdr att) (cdr attTest)) (setq changed t item (subst att attTest item))) (setq changed t item (cons att item)))) ;; Merge into block definition list (if changed (setq lst (subst (cons name (reverse item)) (assoc name lst) lst))))))) (reverse lst)) (defun RenAtt:MergeData (Settings NewData / old old2 attOld len) (foreach item NewData (if (setq old2 (setq old (assoc (car item) Settings))) (foreach att (cdr item) (if (setq attOld (assoc (car att) (cdr old))) (if (> (cdr att) (setq len (1- (length attOld)))) (setq Settings (subst (setq old (subst (append attOld (_MakeList (car att) (- (cdr att) len))) attOld old)) old2 Settings) old2 old)) ;;Some error here (setq Settings (subst (append old (list (cons (car att) (_MakeList (car att) (cdr att))))) old Settings)))) (setq Settings (append Settings (list (cons (car item) (mapcar (function (lambda (attName) (list attName attName))) (apply 'append (mapcar (function (lambda (a) (_MakeList (car a) (cdr a)))) (cdr item)))))))))) Settings) (defun _MakeList (val count / lst) (repeat count (setq lst (cons val lst)))) (defun _FirstN (lst num / res) (if (< num (length lst)) (progn (repeat num (setq res (cons (car lst) res) lst (cdr lst))) (reverse res)) lst)) (defun _CdrN (lst num /) (repeat num (setq lst (cdr lst)))) (defun _ReplaceN (val idx lst /) (if (< idx 0) (cons val lst) (append (_FirstN lst idx) (list val) (_CdrN lst (1+ idx))))) (defun _RemoveN (lst idx /) (if (< idx 0) (cons val lst) (append (_FirstN lst idx) (_CdrN lst (1+ idx))))) (defun RenAttr (obj / setting found) (cond ((and (eq (vla-get-ObjectName obj) "AcDbBlockReference") (eq (vla-get-HasAttributes obj) :vlax-true) (setq setting (assoc (strcase (vla-get-EffectiveName obj)) *RenAtt:Settings*))) (setq setting (cdr setting)) (foreach att (vlax-invoke obj "GetAttributes") (if (setq found (assoc (strcase (vla-get-TagString att)) setting)) (progn (setq setting (_RemoveN setting (vl-position found setting))) (if (not (eq (car found) (cadr found))) (vla-put-TagString att (cadr found))))))) ((and (eq (vla-get-ObjectName obj) "AcDbBlockTableRecord") (setq setting (assoc (strcase (vla-get-Name obj)) *RenAtt:Settings*))) (setq setting (cdr setting)) (vlax-for att obj (if (and (eq (vla-get-ObjectName att) "AcDbAttributeDefinition") (setq found (assoc (strcase (vla-get-TagString att)) setting))) (progn (setq setting (_RemoveN setting (vl-position found setting))) (if (not (eq (car found) (cadr found))) (vla-put-TagString att (cadr found))))))))) (defun c:RenAttr (/) (or *AcadApp* (setq *AcadApp* (vlax-get-acad-object))) (or *ActiveDocument* (setq *ActiveDocument* (vla-get-ActiveDocument *AcadApp*))) (or *BlocksCollection* (setq *BlocksCollection* (vla-get-Blocks *ActiveDocument*))) ;; Get attributes from block definitions (vlax-for blk *BlocksCollection* (if (wcmatch (vla-get-Name blk) "~`**") (RenAttr blk)) (vlax-for obj blk (RenAttr obj))) (princ)) (defun c:RenAttrSet (/ dcl s Blocks Settings ~btnCurrentAdd ~btnCurrentRem ~lstBlocks ~lstAttribs ~btnSave) (if (and (setq dcl (open (setq s (strcat (getvar "TempPrefix") "RenAttrib.DCL")) "w")) (princ (strcat "RenAttrSet : dialog {\n" " label = \"Rename Attributes - Settings\";\n" " : row {\n" " : boxed_column {\n" " label = \"Blocks in current Drawing\";\n" " : list_box { height = 20; key = \"lstCurrent\"; width = 30; multiple_select = true; }\n" " : column {\n" " : button { label = \"Add to Settings\"; key = \"btnCurrentAdd\"; }\n" " : button { label = \"Remove from Settings\"; key = \"btnCurrentRem\"; }\n" " }\n" " }\n" " : boxed_column {\n" " label = \"Settings\";\n" " :row { : column {\n" " : list_box { label = \"Block Names\"; key = \"lstBlocks\"; width = 30; height = 20; }\n" " : edit_box { label = \"New Name\"; key = \"edtName\"; edit_width = 25; }\n" " }\n" " : column {\n" " : list_box { label = \"Old Attribute Names\"; key = \"lstAttribs\"; width = 30; height = 20; }\n" " : retirement_button { key = \"btnSave\"; label = \" Save \"; }\n" " }}\n" " : row {\n" " fixed_width = true;\n" " alignment = centered;\n" " : button { label = \"Clear\"; key = \"clear\"; action = \"(done_dialog 2)\"; }\n" " : spacer { width = 2; }\n" " ok_button;\n" " : spacer { width = 2; }\n" " cancel_button;\n" " }\n" " }\n" " }\n" "}") dcl) (not (close dcl)) (setq dcl (load_dialog s)) (new_dialog "RenAttrSet" dcl)) (progn ;; Action on button "Add to Settings" clicked (defun ~btnCurrentAdd (/ idx) (if (not (eq (setq idx (get_tile "lstCurrent")) "")) (progn (setq idx (mapcar (function (lambda (n) (nth n Blocks))) (read (strcat "(" idx ")"))) Settings (RenAtt:MergeData Settings idx)) (start_list "lstBlocks") (mapcar 'add_list (mapcar 'car Settings)) (end_list) (set_tile "lstBlocks" "") (~lstBlocks)))) ;; Action on button "Add to Settings" clicked (defun ~btnCurrentRem (/ idx) (if (not (eq (setq idx (get_tile "lstCurrent")) "")) (progn (setq idx (mapcar (function (lambda (n) (nth n Blocks))) (read (strcat "(" idx ")")))) (foreach i idx (setq i (assoc (car i) Settings) Settings (vl-remove i Settings))) (start_list "lstBlocks") (mapcar 'add_list (mapcar 'car Settings)) (end_list) (set_tile "lstBlocks" "") (~lstBlocks)))) ;; Action on selection "Block Names" changed (defun ~lstBlocks (/ idx) (if (not (eq (setq idx (get_tile "lstBlocks")) "")) (progn (start_list "lstAttribs") (mapcar 'add_list (mapcar (function (lambda (att) (if (eq (car att) (cadr att)) (car att) (strcat (car att) " <" (cadr att) ">")))) (cdr (nth (atoi idx) Settings)))) (end_list) (mode_tile "lstAttribs" 0) (set_tile "lstAttribs" "")) (progn (start_list "lstAttribs") (setq idxLst nil) (end_list) (mode_tile "lstAttribs" 1) (set_tile "lstAttribs" ""))) (~lstAttribs)) ;; Action on selection "Old Attribute Names" changed (defun ~lstAttribs (/ idx1 idx2 blk att) (if (and (not (eq (setq idx1 (get_tile "lstBlocks")) "")) (not (eq (setq idx2 (get_tile "lstAttribs")) "")) (setq blk (nth (atoi idx1) Settings)) (setq att (nth (atoi idx2) (cdr blk)))) (progn (set_tile "edtName" (cadr att)) (mode_tile "edtName" 0) (mode_tile "btnSave" 0)) (progn (set_tile "edtName" "") (mode_tile "edtName" 1) (mode_tile "btnSave" 1)))) ;; Action on button "Save" clicked (defun ~btnSave (/ idx1 idx2 blk att) (if (and (not (eq (setq idx1 (get_tile "lstBlocks")) "")) (not (eq (setq idx2 (get_tile "lstAttribs")) "")) (setq idx1 (atoi idx1) idx2 (atoi idx2)) (setq blk (nth idx1 Settings)) (setq att (nth idx2 (cdr blk)))) (progn (setq Settings (subst (cons (car blk) (_ReplaceN (list (car att) (strcase (get_tile "edtName"))) idx2 (cdr blk))) blk Settings)) (~lstBlocks) (set_tile "lstAttribs" (itoa idx2)) (~lstAttribs)))) (start_list "lstCurrent") (mapcar 'add_list (mapcar 'car (setq Blocks (RenAtt:GetBlocks)))) (end_list) (setq Settings *RenAtt:Settings*) (start_list "lstBlocks") (mapcar 'add_list (mapcar 'car Settings)) (end_list) (action_tile "btnCurrentAdd" "(~btnCurrentAdd)") (action_tile "btnCurrentRem" "(~btnCurrentRem)") (action_tile "lstBlocks" "(~lstBlocks)") (action_tile "lstBlocks" "(~lstBlocks)") (action_tile "lstAttribs" "(~lstAttribs)") (action_tile "btnSave" "(~btnSave)") (cond ((= (setq s (start_dialog)) 1) (setq *RenAtt:Settings* Settings) (RenAtt:SaveSettings nil) (unload_dialog dcl)) ((= s 2) (if (eq (progn (initget "Yes No") (getkword "Are you sure you want to clear all block settings? [Yes/No] : ")) "Yes") (while (setq s (cond ((findfile "RenAttrib.DAT")) ((findfile (strcat (getvar "RoamableRootPrefix") "RenAttrib.DAT"))))) (vl-file-delete s))) (unload_dialog dcl) (c:RenAttrSet)) (t (unload_dialog dcl))) )) (princ)) ;|«Visual LISP© Format Options» (120 2 1 0 nil "end of " 100 9 0 0 0 nil T nil T) ;*** DO NOT add text below the comment! ***|;