(defun c:changexrcolor ()
(command
"-layer"
"color"
(acad_colordlg 1)
"*|*"
"")
)
(princ)
(defun c:xr-c(/ ActDoc Sel Clr Data XrName )
; Change all the layers of an xref to selected color.
(vl-load-com)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(initget "All")
(if
(and
(setq Sel (entsel "\n Select xref to change color of all layers: "))
(setq XrName
(if (= Sel "All")
"*|*"
(if
(and
(setq Data (entget (car Sel)))
(= (cdr (assoc 0 Data)) "INSERT")
(setq XrName (cdr (assoc 2 Data)))
(equal (logand (cdr (assoc 70 (tblsearch "block" XrName))) 4) 4)
)
(setq XrName (strcat XrName "|*"))
)
)
)
(setq Clr (acad_colordlg 252))
)
(progn
(vlax-for i (vla-get-Layers ActDoc)
(if (wcmatch (vla-get-Name i) XrName)
(vla-put-Color i Clr)
)
)
(vla-Regen ActDoc acActiveViewport)
)
)
(vla-EndUndoMark ActDoc)
(princ)
)
; Original by T.Willey at http://www.theswamp.org/index.php?topic=35168.0
; Modified by cmwade77 to allow for selecting multiple xrefs as well as nested xrefs (as an option) and Plotystyle when available
(defun c:xradjust (/ ActDoc Sel Data XrName xRefs ct i ct2)
; Change all the layers of an xref to selected color.
(vl-load-com)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(if (= Clr nil)
(setq Clr 8)
)
(if (= nested nil)
(setq nested "Yes")
)
(if (= pstyle nil)
(setq pstyle "No Change")
)
(setq kWord T)
(while (/= kWord nil)
(cond
((= (getvar "PSTYLEMODE") 0)
(initget "Color Plotstyle Nested _Color PS Nested")
(setq kWord (getkword (strcat "\nColor: " (rtos clr 2 0) "/Plotstyle: " pstyle "/Nested: " nested " <Press Enter to Continue>: ")))
)
(T
(initget "Color Nested _Color Nested")
(setq kWord (getkword (strcat "\nColor: " (rtos clr 2 0) "/Nested: " nested " <Press Enter to Continue>: ")))
)
)
(cond
((= kWord "Color")
(setq Clr (acad_colordlg 8))
)
((= kWord "Nested")
(initget 1 "Yes No")
(setq nested (getkword "\nDo you want to include nested xrefs? (Yes/No) "))
)
((= kWord "PS")
(setq pstyle (getstring T "\nType plotstyle to use (No Change): "))
)
)
)
(while (= xRefs nil)
(setq xRefs (ssget))
)
(setq ct 0)
(while (< ct (sslength xRefs))
(setq Sel (ssname xRefs ct))
(setq ct (+ ct 1)
Data (entget Sel))
(if (= (cdr (assoc 0 Data)) "INSERT")
(progn
(setq XrName (cdr (assoc 2 Data)))
(cond
((= nested "Yes")
(setq MyList nil)
(nxr XrName)
)
)
(if (equal (logand (cdr (assoc 70 (tblsearch "block" XrName))) 4) 4)
(vlax-for i (vla-get-Layers ActDoc)
(if (wcmatch (vla-get-Name i) (strcat XrName "|*"))
(progn
(vla-put-Color i Clr)
(cond
((and (= (getvar "PSTYLEMODE") 0) (/= (strcase pstyle) "NO CHANGE"))
(vla-put-plotstylename i pstyle)
)
)
)
)
(cond
((= nested "Yes")
(setq ct2 0)
(while (< ct2 (length MyList))
(if (wcmatch (vla-get-Name i) (strcat (nth ct2 MyList) "|*"))
(progn
(vla-put-Color i Clr)
(cond
((and (= (getvar "PSTYLEMODE") 0) (/= (strcase pstyle) "NO CHANGE"))
(vla-put-plotstylename i pstyle)
)
)
)
)
(setq ct2 (+ ct2 1))
)
)
)
)
)
)
)
)
(vla-Regen ActDoc acActiveViewport)
(vla-EndUndoMark ActDoc)
(princ)
)
; The code below has been adapted from:
; T. Willey's Code at http://www.theswamp.org/index.php?topic=34277.0
(defun nxr ( xr / GetXrefNesting PrintNestedList )
; Prints nested xref tree to command line, no matter how deep the nesting.
(defun GetXrefNesting (/ GetXrefInfo tempData tempEnt XrefList NonNestedXrefList NestedXrefList )
(defun GetXrefInfo ( ent / NestList )
(foreach i (member '(102 . "{BLKREFS") (entget ent))
(if (equal (car i) 332)
(progn
(setq NestedList (cons (cdr i) NestedList))
(setq NestList
(cons
(cons
(cdr i)
(GetXrefInfo (cdr i))
)
NestList
)
)
)
)
)
NestList
)
;-------------------------------------
(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempEnt (cdr (assoc 330 (entget tempEnt))))
(setq XrefList
(cons
(cons
tempEnt
(GetXrefInfo tempEnt)
)
XrefList
)
)
)
)
)
(foreach i XrefList
(if (not (member (car i) NestedList))
(setq NonNestedXrefList (cons i NonNestedXrefList))
)
)
NonNestedXrefList
)
;------------------------------------------------
(defun PrintNestedList ( lst spc )
(foreach
i
(vl-sort
lst
(function
(lambda ( a b )
(<
(strcase (cdr (assoc 2 (entget (car a)))))
(strcase (cdr (assoc 2 (entget (car b)))))
)
)
)
)
(setq NX (cdr (assoc 2 (entget (car i)))))
(if (= MyList nil)
(setq MyList (list NX))
(setq MyList (append MyList (list NX)))
)
;(prompt (strcat "\n" spc " Nested xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) (strcat " " spc))
;(PrintNestedList (cdr i) (strcat " |" spc)) ; second option shown below
)
)
;-----------------------------------------------------
(foreach
i
(vl-sort
(GetXrefNesting)
(function
(lambda ( a b )
(<
(strcase (cdr (assoc 2 (entget (car a)))))
(strcase (cdr (assoc 2 (entget (car b)))))
)
)
)
)
(if (= xr (cdr (assoc 2 (entget (car i)))))
(progn
;(prompt (strcat "\n Main xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) " |-")
)
)
)
(princ)
)
(defun C:COLORXLAY (/ doc col xreflist ret)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for item (vla-get-Blocks doc)
(if (= (vla-get-IsXref item) :vlax-true)
(setq xreflist (cons (vla-get-name item) xreflist))
)
)
(if xreflist
(if (and (setq ret (_dwgru-get-user-dcl "Select XREF " (acad_strlsort xreflist) t))
(setq col (acad_colordlg 7 nil))
)
(progn
(setq ret (apply 'strcat (mapcar '(lambda(x)(strcat x "|*,")) ret)))
(vla-startundomark doc)
(vlax-for item (vla-get-Layers doc)
(if (wcmatch (vla-get-name item) ret)
(vla-put-color item col)
)
)
(vla-endundomark doc)
)
) ;_ end of if
(alert "No XREF Found")
)
(princ)
) ;_ end of defun
;;; ************************************************************************
;;; * Library DWGruLispLib Copyright © 2008 DWGru Programmers Group
;;; *
;;; * _dwgru-get-user-dcl (Candidate)
;;; *
;;; * Inquiry of value at the user through a dialogue window
;;; *
;;; *
;;; * 26/01/2008 Version 0002. Edition Vladimir Azarko (VVA)
;;; - the Output on double a clique if the plural choice (multi-nil) is forbidden
;;; - Processing of several columns
;;; * 21/01/2008 Version 0001. Edition Vladimir Azarko (VVA)
(defun _DWGRU-GET-USER-DCL (ZAGL INFO-LIST MULTI
/ FL RET
DCL_ID MAXROW MAX_COUNT_COL
COUNT_COL I LISTBOX_HEIGHT
LST _LOC_FINISH _LOC_CLEAR
NCOL
)
;|
* Inquiry of value at the user through a dialogue window
* Dialogue is formed to "strike"
* the Quantity of lines on page without scrolling is set by variable MAXROW.
* It is necessary to remember, that number MAXROW increases on 3.
* the Maximum quantity of columns is set by variable MAX_COUNT_COL
* It is published
http://dwg.ru/f/showthread.php?p=203746#post203746
* Parameters of a call:
zagl - heading of a window [String]
info-list - the list of line values[List of String]
multi - t - the plural choice is resolved, nil-is not present
* Returns:
The list of the chosen lines or nil - a cancelling
* the Example
(_dwgru-get-user-dcl " Specify a variant " ' ("First" "Second" "Third") nil); _-> ("First")
(_dwgru-get-user-dcl " Specify a variant " ' ("First" "Second" "Third") t); _-> ("First" "Second ")
(_dwgru-get-user-dcl " Specify a variant "
(progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "Value-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) nil)
(_dwgru-get-user-dcl " Specify a variant, using CTRL and SHIFT for a choice "
(progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "Value-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) t)
|;
(setq MAXROW 40) ;_ max lines without scrolling (To it 3 more lines further will be added)
(setq MAX_COUNT_COL 5) ; _ a maximum quantity of columns
;;============== Local functions START========================
(defun _LOC_FINISH ()
(setq I 0
RET NIL
) ;_ end ofsetq
(repeat COUNT_COL
(setq I (1+ I))
(setq RET (cons (cons I (get_tile (strcat "info" (itoa I)))) RET))
) ;_ end ofrepeat
(setq RET (reverse RET))
(done_dialog 1)
) ;_ end ofdefun
(defun _LOC_CLEAR (NOMER)
(setq I 0)
(repeat COUNT_COL
(setq I (1+ I))
(if (/= I NOMER)
(progn
(start_list (strcat "info" (itoa I)))
(mapcar 'add_list (nth (1- I) LST))
(end_list)
) ;_ end ofprogn
) ;_ end ofif
) ;_ end ofrepeat
) ;_ end ofdefun
;;;==================== Local functions END ==================================
;;;==================== MAIN PART ===============================================
(if (null ZAGL)(setq ZAGL "Select")) ;_ end if
(if (zerop (rem (length INFO-LIST) MAXROW))
(setq COUNT_COL (/ (length INFO-LIST) MAXROW))
(setq COUNT_COL (1+ (fix (/ (length INFO-LIST) MAXROW 1.0))))
) ;_ end ofif
(if (> COUNT_COL MAX_COUNT_COL)
(setq COUNT_COL MAX_COUNT_COL)
)
(setq LISTBOX_HEIGHT (+ 3 MAXROW))
;_ We add 3 lines for appearance and for exception boundary scroll
(if (and (= COUNT_COL 1) (<= (length INFO-LIST) MAXROW))
(setq LISTBOX_HEIGHT (+ 3 (length INFO-LIST)))
) ;_ end ofif
(setq I 0)
(setq FL (vl-filename-mktemp "dwgru" NIL ".dcl"))
(setq RET (open FL "w")
LST NIL
) ;_ end ofsetq
(mapcar '(lambda (X) (write-line X RET))
(append (list "dwgru_get_user : dialog { "
(strcat "label=\"" ZAGL "\";")
": boxed_row {"
"label = \"Value\";"
) ;_ end oflist
(repeat COUNT_COL
(setq LST
(append
LST
(list
" :list_box {"
"alignment=top ;"
(if MULTI
"multiple_select = true ;"
"multiple_select = false ;"
) ;_ end ofif
"width=31 ;"
(strcat "height= " (itoa LISTBOX_HEIGHT) " ;")
"is_tab_stop = false ;"
(strcat "key = \"info" (itoa (setq I (1+ I))) "\";}")
) ;_ end oflist
) ;_ end ofappend
) ;_ end ofsetq
) ;_ end ofrepeat
(list
"}"
":row{"
"ok_cancel_err;}}"
) ;_ end oflist
) ;_ end of list
) ;_ end of mapcar
(setq RET (close RET))
(if (and (null (minusp (setq DCL_ID (load_dialog FL))))
(new_dialog "dwgru_get_user" DCL_ID)
) ;_ end and
(progn
(setq LST INFO-LIST)
((lambda (/ RET1 BUF ITM)
(repeat (1- COUNT_COL)
(setq I '-1)
(while (and (setq ITM (car LST))
(< (setq I (1+ I)) MAXROW)
) ;_ end of and
(setq BUF (cons ITM BUF)
LST (cdr LST)
) ;_ end of setq
) ;_ end ofwhile
(setq RET1 (cons (reverse BUF) RET1)
BUF NIL
) ;_ end of setq
) ;_ end of repeat
(setq RET RET1)
) ;_ end of lambda
)
(if LST
(setq RET (cons LST RET))
) ;_ end ofif
(setq LST (reverse RET))
(setq I 0)
(mapcar '(lambda (THIS_LIST)
(if (<= (setq I (1+ I)) COUNT_COL)
(progn
(start_list (strcat "info" (itoa I)))
(mapcar 'add_list THIS_LIST)
(end_list)
) ;_ end ofprogn
) ;_ end ofif
) ;_ end oflambda
LST
) ;_ end ofmapcar
(set_tile "info1" "0")
(setq I 0
NCOL 1
) ;_ end ofsetq
(repeat COUNT_COL
(action_tile
(strcat "info" (itoa (setq I (1+ I))))
(strcat "(progn (setq Ncol "
(itoa I)
")(if (not multi)(_loc_clear Ncol))"
"(if (and (not multi)(= $reason 4))(_loc_finish)))"
) ;_ end ofstrcat
) ;_ end ofaction_tile
) ;_ end ofrepeat
(action_tile "cancel" "(done_dialog 0)")
(action_tile "accept" "(_loc_finish)")
(if MULTI
(set_tile "error" "Use CTRL and SHIFT for a choicet") ;_ end ofset_tile
(set_tile "error" "It is possible to choose double click") ;_ end ofset_tile
) ;_ end ofif
(if (zerop (start_dialog))
(setq RET NIL)
(progn
(setq
RET (apply
'append
(mapcar
'(lambda (ITM)
(setq THIS_LIST (nth (1- (car ITM)) LST))
(mapcar
(function (lambda (NUM) (nth NUM THIS_LIST)))
(read (strcat "(" (cdr ITM) ")"))
) ;_ end ofmapcar
) ;_ end oflambda
RET
) ;_ end ofmapcar
) ;_ end ofapply
) ;_ end ofsetq
) ;_ end ofprogn
) ;_ end if
(unload_dialog DCL_ID)
) ;_ end of progn
) ;_ end of if
(vl-file-delete FL)
RET
) ;_ end ofdefun
Othe ColorX... command (http://www.cadtutor.net/forum/showthread.php?533-Lisp-colour-change-for-all-layers-and-blocks&p=221559&viewfull=1#post221559)Command:
ColorX - change color all object of drawing. All layer unlock and thaw
ColorXREF - change color xref only on a current session. All layer unlock and thaw
ColorXL - change color all object of drawing. Objects on the locked and frozen layers are ignored
ColorXREFL - change color xref only on a current session. Objects on the locked and frozen layers are ignored
;Code Modified from T. Willey's Code at: http://www.theswamp.org/index.php?topic=35168.msg403946#msg403946
;Modified by Chris Wade - 06/06/2018 to allow for
;Selecting multiple xrefs
;Handling NestedxRefs
;Using default settings
;Setting plotstyle as well as color
(defun c:xrc (/ ActDoc Sel Clr Data XrName Pstyle Nested NestedList xName ct sCt xRefs)
(setq clr 8 ;Sets the color
Pstyle "Shaded" ;Sets PlotStyle if applicable
Nested T ;If nil nested xrefs will not be processed
)
; The code below has been adapted from:
; T. Willey's Code at http://www.theswamp.org/index.php?topic=34277.0
(defun nxr ( xr / GetXrefNesting PrintNestedList MyList xRefs)
; Prints nested xref tree to command line, no matter how deep the nesting.
(defun GetXrefNesting (/ GetXrefInfo tempData tempEnt XrefList NonNestedXrefList NestedXrefList )
(defun GetXrefInfo ( ent / NestList )
(foreach i (member '(102 . "{BLKREFS") (entget ent))
(if (equal (car i) 332)
(progn
(setq NestedList (cons (cdr i) NestedList))
(setq NestList
(cons
(cons
(cdr i)
(GetXrefInfo (cdr i))
)
NestList
)
)
)
)
)
NestList
)
;-------------------------------------
(while (setq tempData (tblnext "block" (not tempData)))
(if (equal (logand (cdr (assoc 70 tempData)) 4) 4)
(progn
(setq tempEnt (tblobjname "block" (cdr (assoc 2 tempData))))
(setq tempEnt (cdr (assoc 330 (entget tempEnt))))
(setq XrefList
(cons
(cons
tempEnt
(GetXrefInfo tempEnt)
)
XrefList
)
)
)
)
)
(foreach i XrefList
(if (not (member (car i) NestedList))
(setq NonNestedXrefList (cons i NonNestedXrefList))
)
)
NonNestedXrefList
)
;------------------------------------------------
(defun PrintNestedList ( lst spc )
(foreach
i
(vl-sort
lst
(function
(lambda ( a b )
(<
(strcase (cdr (assoc 2 (entget (car a)))))
(strcase (cdr (assoc 2 (entget (car b)))))
)
)
)
)
(setq NX (cdr (assoc 2 (entget (car i)))))
(if (= MyList nil)
(setq MyList (list NX))
(setq MyList (append MyList (list NX)))
)
;(prompt (strcat "\n" spc " Nested xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) (strcat " " spc))
;(PrintNestedList (cdr i) (strcat " |" spc)) ; second option shown below
)
)
;-----------------------------------------------------
(foreach
i
(vl-sort
(GetXrefNesting)
(function
(lambda ( a b )
(<
(strcase (cdr (assoc 2 (entget (car a)))))
(strcase (cdr (assoc 2 (entget (car b)))))
)
)
)
)
(if (= xr (cdr (assoc 2 (entget (car i)))))
(progn
;(prompt (strcat "\n Main xref: " (cdr (assoc 2 (entget (car i))))))
(PrintNestedList (cdr i) " |-")
)
)
)
MyList
)
(defun ChangeNow (XrName Clr PStyle / i ActDoc)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vlax-for i (vla-get-Layers ActDoc)
(if (wcmatch (vla-get-Name i) XrName)
(progn
(vla-put-Color i Clr)
(if (and (= (getvar "pstylemode") 0) (/= pstyle nil))
(vla-put-plotstylename i pstyle)
)
)
)
)
)
; Change all the layers of an xref to selected color.
(vl-load-com)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(while (= xRefs nil)
(princ "\rSelect xRefs to change: ")
(setq xRefs (ssget (list (cons 0 "INSERT"))))
)
(setq sCt 0)
(while (< sCt (sslength xRefs))
(setq Sel (ssname xRefs sCt)
sCt (+ sCt 1)
Data (entget Sel)
)
(if (= (cdr (assoc 0 Data)) "INSERT")
(setq xName (cdr (assoc 2 Data)))
)
(setq XrName
(if
(and
(setq Data (entget Sel))
(= (cdr (assoc 0 Data)) "INSERT")
(setq XrName (cdr (assoc 2 Data)))
(equal (logand (cdr (assoc 70 (tblsearch "block" XrName))) 4) 4)
)
(setq XrName (strcat xName "|*"))
)
)
(if (and (/= xName nil) (/= XrName nil))
(progn
(if (and (/= xName "") (/= xRname ""))
(progn
(ChangeNow XrName Clr PStyle)
(if Nested
(Progn
(setq NestedList (nxr xName))
(if (/= NestedList nil)
(progn
(setq ct 0)
(while (< ct (length MyList))
(setq xName (strcat (nth ct NestedList))
XrName (strcat xName "|*")
)
(ChangeNow XrName Clr PStyle)
(setq ct (+ ct 1))
)
)
)
)
)
)
)
)
)
)
(vla-Regen ActDoc acActiveViewport)
(vla-EndUndoMark ActDoc)
(princ)
)