hyposmurf
Just to look at this from another perspective.
The Library code < second code block > is just that ; a group of generic modules, each to do a specific single task.
This method allows your function to be written with a smaller footprint and be error trapped and reasonably easy to read and test.
... and the library stuff can be re-used in the next function you write.
(vl-load-com)
(setq kbsg:activedoc (vla-get-activedocument (vlax-get-acad-object)))
(defun c:matchblocks (/ *error* master clone)
(defun *error* (msg /) (kbsl_on-error msg))
(vla-endundomark kbsg:activedoc)
(vla-startundomark kbsg:activedoc)
(setq master (car (kbsl_entsel "Select Master block" nil nil (list "INSERT") nil t))
clone (car (kbsl_entsel "Select block to update" nil nil (list "INSERT") nil t))
)
(kbsl_setattributes (vlax-ename->vla-object clone)
(kbsl_getattributelist (vlax-ename->vla-object master))
)
(*error* nil)
)
LIBRARY CODE
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;
;;; kwb 20021103
;;; kbsl_entsel (msg kwd def typelist selectflag lockflag
;;; Arguments:
;;; msg : The prompt string.
;;; kwd : Initget keywords string.
;;; def : Value to return if response is <enter>.
;;; typelist : Stringlist of entity types allowed for selection. If nil select anything.
;;; selectflag : If true nentsel permitted , otherwise use entsel.
;;; lockflag : If true dont allow selection from locked layers.
;;;
;;; Note : Arguments may be set to nil
;;;
;;; Return output from (n)entsel, a key word, the default argument, or nil.
;;;
;; example1 : (kbsl_EntSel "Select Arc Object" nil nil (list "ARC" "CIRCLE") nil T)
;; ==> (<Entity name: 40bcd540> (-28175.1 154575.0 1250.0))
;; example2 : (kbsl_EntSel "Select Datum Line" nil nil (list "LINE") T T) ; line in block
;; ==> (<Entity name: 4022c680> (-21613.1 142392.0 0.0)
;; ((70.0 0.0 0.0) (0.0 70.0 0.0) (0.0 0.0 70.0) (-21611.9 142635.0 0.0))
;; (<Entity name: 4022c6b8>) )
(defun kbsl_entsel (msg kwd def typelist selectflag lockflag / pickok returnvalue tmp)
(setq msg (strcat "\n"
(cond (msg)
("Select object")
)
" : "
)
)
(while (not pickok)
(setvar "ERRNO" 0)
(if kwd
(initget kwd)
)
(setq returnvalue (if selectflag
(nentsel msg)
(entsel msg)
)
)
(cond
((= (getvar "ERRNO") 52) ; enter
(if def
(setq returnvalue def)
)
;; skip out
(setq pickok t)
)
((= (getvar "ERRNO") 7) (princ "Nothing found at selectedpoint. "))
((= (type returnvalue) 'str) (setq pickok t)) ; keyword
((and (setq tmp (entget (car returnvalue))) ; object type
typelist
(not (member (cdr (assoc 0 tmp)) (mapcar 'strcase typelist)))
) ; wrong type
(alert (strcat "Selected object is not"
"\na "
(apply 'strcat
(cons (car typelist)
(mapcar '(lambda (x) (strcat "\nor " x)) (cdr typelist))
)
)
". "
)
)
)
((and lockflag ;Locked Layer Not Permitted
(setq ;layer name
tmp (entget (tblobjname "LAYER" (cdr (assoc 8 tmp))))
)
(= (logand 4 (cdr (assoc 70 tmp))) 4) ;is layer locked
)
(princ "Selected object is on a locked layer. ")
)
;; skip out
((setq pickok t))
)
)
returnvalue
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;
(defun kbsl_on-error (msg / tmp)
;;----- Cancel any Active Commands -----------------------------
(while (< 0 (getvar "cmdactive")) (command))
(setvar "menuecho" 1)
(vla-endundomark kbsg:activedoc)
;;----- Display error message if applicable _-------------------
(cond ((not msg)) ; no error, do nothing
((member (strcase msg t) ; cancel
'("console break" "function cancelled" "quit / exit abort")
)
)
((princ (strcat "\nApplication Error: " (itoa (getvar "errno")) " :- " msg)))
)
(setvar "errno" 0)
;;----- Display backtrace if in debug mode ---------------------
(if kbsg:debug_on
(vl-bt)
)
;;----- Release Bound Activex Objects --------------------------
(foreach varname kbsg:objectsbound
(if (= (type (setq tmp (vl-symbol-value varname))) 'vla-object)
(if (not (vlax-object-released-p tmp))
(progn (vlax-release-object tmp) (set varname nil))
)
)
)
;;----- Reset System Variables from global list ----------------
(foreach item kbsg:sysvarlist (setvar (car item) (cadr item)))
(setq kbsg:sysvarlist nil
kbsg:objectsbound nil
)
(princ)
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;
(defun kbsl_getattributelist (blockref / catchit returnval)
(if (vl-catch-all-error-p
(setq catchit (vl-catch-all-apply 'vlax-invoke (list blockref 'getattributes)))
)
(alert (vl-catch-all-error-message catchit))
;; else
(setq
returnval (mapcar '(lambda (attref)
(cons (vla-get-tagstring attref) (vla-get-textstring attref))
)
catchit
)
)
)
returnval
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;
(defun kbsl_setattributes (blockref dotlist / catchit attval)
(if (vl-catch-all-error-p
(setq catchit (vl-catch-all-apply 'vlax-invoke (list blockref 'getattributes)))
)
(alert (vl-catch-all-error-message catchit))
;; else
(progn (mapcar '(lambda (attref)
(if (setq attval (cdr (assoc (vla-get-tagstring attref) dotlist)))
(vla-put-textstring attref attval)
)
)
catchit
)
(vla-update blockref)
)
)
(princ)
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;
