315 lines
13 KiB
Common Lisp
315 lines
13 KiB
Common Lisp
;;; 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] <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! ***|;
|