OK, Dan I modified the code again.
I added an Off feature, entering VLR_COMMAND_OFF will turn the reactor off.
Entering VLR_COMMAND will activate or turn the reactor On.
setting *user* to DAN will produce the layers you want.
You may add additional layer choices, say for other vendors or other disciplines.
There is also a default Layer group in case *user* is nil or unrecognised.
I haven't done any reactor code to speak of so if anyone see a problem please let me know.
; Modified by CAB 01.25.2008
; Modified by CAB 04.25.2008 ; bug fix
; Sets the correct layer for certain commands.
; VLR_COMMAND.lsp courtesy Peter Jamtgaard 2003
; Vlr Command is a function that will switch the active layer in a drawing.
; The reactor checks the command that is starting and if it recognizes it
; it will switch to a specified layer. If the layer doesn't exist it will
; create it with the color, linetype, and plottable setting provided.
; To load and run this program add the lines (load "vlr_command")(c:vlr_command)
; to your acaddoc.lsp or another autoloading lisp routine.
; CAB added error trap for layer creator
; added layer restore at command exit
;; added code to test loaded status
;; added code to turn reactors Off & back On again
;; added code for different layers per user or task
;; NOTE: set var *user* to use different layers per user
;; Fixed bug in end & cancel command layer reset
(defun C:VLR_COMMAND ()
(vl-load-com)
;; Load only once, if already loaded reactivate it if inactive
(and *vlr-CWS (not (vlr-added-p *vlr-CWS)) (vlr-add *vlr-CWS))
(and *vlr-CE (not (vlr-added-p *vlr-CE)) (vlr-add *vlr-CE))
(and *vlr-CC (not (vlr-added-p *vlr-CC)) (vlr-add *vlr-CC))
(or *vlr-CWS
(setq *vlr-CWS (vlr-command-reactor nil '((:vlr-commandwillstart . StartCommand)))))
(or *vlr-CE
(setq *vlr-CE (vlr-command-reactor nil '((:vlr-commandEnded . endCommand)))))
(or *vlr-CC
(setq *vlr-CC (vlr-command-reactor nil '((:vlr-commandCancelled . cancelCommand)))))
(princ "\nLayer Reactor ON")
(princ)
)
;; Turn the reactors off
(defun C:VLR_COMMAND_OFF ()
(and *vlr-CWS (vlr-added-p *vlr-CWS) (vlr-remove *vlr-CWS))
(and *vlr-CE (vlr-added-p *vlr-CE) (vlr-remove *vlr-CE))
(and *vlr-CC (vlr-added-p *vlr-CC) (vlr-remove *vlr-CC))
(princ "\nLayer Reactor OFF")
(princ)
)
(defun StartCommand (CALL CALLBACK / COMLAYLST)
;; Examples of Command vs Layer
;; List of corresponding command layerName color linetype plottable
;; NOTE command names must be in Upper Case
;; NOTE: set var *user* to use different layers per user
(cond
((and *user*(= (type *user*) 'STR)(= (strcase *user*) "DAN"))
(setq *LayUpdt* t
LtFname nil)
(setq COMLAYLST
(list
(list "DIMANGULAR" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMBASELINE" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMCENTER" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMCONTINUE" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMDIAMETER" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMLINEAR" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "DIMRADIUS" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "QDIM" "I_ANNO-DIMS" 14 "continuous" :vlax-true)
(list "LEADER" "I_ANNO-NOTE" 11 "continuous" :vlax-true)
(list "QLEADER" "I_ANNO-NOTE" 11 "continuous" :vlax-true)
(list "DTEXT" "I_ANNO-NOTE" 11 "continuous" :vlax-true)
(list "MTEXT" "I_ANNO-NOTE" 11 "continuous" :vlax-true)
(list "TEXT" "I_ANNO-NOTE" 11 "continuous" :vlax-true)
(list "BHATCH" "I-FIXT-7" 8 "continuous" :vlax-true)
(list "HATCH" "I-FIXT-7" 8 "continuous" :vlax-true)
(list "MVIEW" "Z-VIEWPORT" 7 "continuous" :vlax-false)
; Add your own command layer lists here....
)
)
)
((and *user*(= (type *user*) 'STR)(= (strcase *user*) "Future Use"))
(setq COMLAYLST '())
)
((and *usermode*(= (type *usermode*) 'STR)(= (strcase *usermode*) "CAB"))
(setq *LayUpdt* nil
LtFname "CAB2.lin")
(setq COMLAYLST
(list
(list "DIMANGULAR" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMBASELINE" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMCENTER" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMCONTINUE" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMDIAMETER" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMLINEAR" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMRADIUS" "S-DIM" 5 "continuous" :vlax-true)
(list "QDIM" "S-DIM" 5 "continuous" :vlax-true)
(list "LEADER" "A-DIM" 5 "continuous" :vlax-true)
(list "QLEADER" "A-DIM" 5 "continuous" :vlax-true)
(list "DTEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "MTEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "TEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "BHATCH" "A-HATCH" 8 "continuous" :vlax-true)
(list "HATCH" "A-HATCH" 8 "continuous" :vlax-true)
(list "POINT" "A-POINTS" 7 "continuous" :vlax-true)
(list "XLINE" "A-CONST-LINES" 9 "continuous" :vlax-true)
(list "MVIEW" "A-VIEWPORT" 7 "continuous" :vlax-false)
(list "TABLE" "A-TABLE" 2 "continuous" :vlax-true)
(list "REVCLOUD" "A-REVCLOUD" 7 "continuous" :vlax-true)
; Add your own command layer lists here....
)
)
)
(t ; default Layer Group
(setq *LayUpdt* nil
LtFname "CAB2.lin")
(setq COMLAYLST
(list
(list "DIMANGULAR" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMBASELINE" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMCENTER" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMCONTINUE" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMDIAMETER" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMLINEAR" "S-DIM" 5 "continuous" :vlax-true)
(list "DIMRADIUS" "S-DIM" 5 "continuous" :vlax-true)
(list "QDIM" "S-DIM" 5 "continuous" :vlax-true)
(list "LEADER" "A-DIM" 5 "continuous" :vlax-true)
(list "QLEADER" "A-DIM" 5 "continuous" :vlax-true)
(list "DTEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "MTEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "TEXT" "A-TEXT" 2 "continuous" :vlax-true)
(list "BHATCH" "A-HATCH" 8 "continuous" :vlax-true)
(list "HATCH" "A-HATCH" 8 "continuous" :vlax-true)
(list "POINT" "A-POINTS" 7 "continuous" :vlax-true)
(list "XLINE" "A-CONST-LINES" 9 "continuous" :vlax-true)
(list "MVIEW" "A-VIEWPORT" 7 "continuous" :vlax-false)
(list "TABLE" "A-TABLE" 2 "continuous" :vlax-true)
(list "REVCLOUD" "A-REVCLOUD" 7 "continuous" :vlax-true)
; Add your own command layer lists here....
)
)
)
)
;; Find the Command
(if (setq N (assoc (strcase (car CALLBACK)) COMLAYLST))
(progn
;; save current layer, restore on exit of command
(setq *Currentlayers* (cons (getvar "CLAYER") *Currentlayers*))
;; make or update layer, then make current
(if (make_layers (cadr N) (caddr N) (cadddr N) (car (cddddr N)))
(vla-put-activelayer
(vla-get-activedocument (vlax-get-acad-object))
(vlax-ename->vla-object (tblobjname "LAYER" (cadr N)))
)
)
)
;; flag current layer so it is NOT restored on exit of command
(setq *Currentlayers* (cons nil *Currentlayers*))
)
(princ)
)
;; Make layers using activeX
;; return t if sucessful else nil
(defun MAKE_LAYERS (LAY_NAM COLOR LTYPE PLOTL / LAYOBJ LAYSOBJ LTYPESOBJ fn result LtFname NewLay)
(or *DOC* (setq *DOC* (vla-get-activedocument (vlax-get-acad-object))))
(setq LAYSOBJ (vla-get-layers *DOC*))
(if (tblobjname "layer" LAY_NAM) ; layer exist
(setq LAYOBJ (vla-item LAYSOBJ LAY_NAM))
(setq LAYOBJ (vl-catch-all-apply 'vla-add (list LAYSOBJ LAY_NAM))
NewLay t)
)
;;(setq LAYOBJ (vla-item LAYSOBJ LAY_NAM))
(if (vl-catch-all-error-p LAYOBJ)
(not (print (vl-catch-all-error-message LAYOBJ)))
(progn
(if (= (strcase (vla-get-name LAYOBJ)) (strcase (getvar "clayer")))
(progn ; can not change current layer so make something else current
;; what if "0" is frozen?
;; need to thaw it then restore old layer, and freeze if thawed.
(setvar "clayer" "0")
)
)
(vla-put-lock LAYOBJ :vlax-false)
(vla-put-layeron LAYOBJ :vlax-true)
(vla-put-freeze LAYOBJ :vlax-false)
(if (or NewLay *LayUpdt*) ; ok to update layer color, plot, LineType
;; ****************************************************************
(progn
(if (tblobjname "ltype" LTYPE)
(vla-put-linetype LAYOBJ LTYPE)
(progn
(setq LTYPESOBJ (vla-get-linetypes *DOC*))
(if (and LtFname (/= LtFname "")
(setq fn (findfile LtFname)))
(vl-catch-all-apply '(lambda ( ) (vla-load LTYPESOBJ LTYPE fn)
(setq result t) ; true only if load susceded
))
)
(if (and (not result)
(setq fn (findfile (if (zerop (getvar "measurement")) "acad.lin" "acadiso.lin"))))
(vl-catch-all-apply '(lambda ( ) (vla-load LTYPESOBJ LTYPE fn)
(setq result t) ; true only if load susceded
))
)
(vlax-release-object LTYPESOBJ)
(and result (vla-put-linetype LAYOBJ LTYPE))
)
)
;; ****************************************************************
(vla-put-color LAYOBJ COLOR)
(vla-put-plottable LAYOBJ PLOTL)
)
) ; end if (or NewLay *LayUpdt*)
t
)
)
)
;; Restore curent layer
(defun endCommand (CALL CALLBACK)
(if *Currentlayers*
(if (car *Currentlayers*)
(progn
(vla-put-lock
(vla-item
(vla-get-layers
(vla-get-activedocument (vlax-get-acad-object)))
(car *Currentlayers*)
)
:vlax-false
)
(setvar "CLAYER" (car *Currentlayers*))
)
)
)
(setq *Currentlayers* (cdr *Currentlayers*))
)
;; Restore curent layer
(defun cancelCommand (CALL CALLBACK)
(if *Currentlayers*
(if (car *Currentlayers*)
(progn
(vla-put-lock
(vla-item
(vla-get-layers
(vla-get-activedocument (vlax-get-acad-object)))
(car *Currentlayers*)
)
:vlax-false
)
(setvar "CLAYER" (car *Currentlayers*))
)
)
)
(setq *Currentlayers* (cdr *Currentlayers*))
)
(princ)
;------------------<The End>--------------------------