;;; ;Stephan Koster 2002, posted to adesk customization ;;; ;newsgroup on 4/21/2002 ;;; (defun XrefTree (/ nested_p build_retlist firstLevelXrefs name ;;; nested-xrefs nestList xrefDBase retList i ;;; ) ;;; (defun nested_p (blockname / tn tmp) ;;; (and (setq tn (tblobjname "block" blockname)) ;;; (setq tmp (entget tn)) ;;; (setq tmp (cdr (assoc 330 tmp))) ;;; (setq tmp (entget tmp)) ;;; (not (member '(102 . "{BLKREFS") tmp)) ;;; ) ;;; ) ;;; ;;; ;;; (defun build_retlist(name / next) ;;; (setq retList (cons (cons i name) retList)) ;;; (and (setq next (cdr (assoc name nestList))) ;;; (setq i (1+ i)) ;;; (foreach z next (build_retlist z)) ;;; (setq i (1- i)) ;;; ) ;;; ) ;;; ;;; ;;; (vlax-for x (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) ;;; (if (= (vla-get-isXref x) :vlax-true) ;;; (progn ;;; (setq name (vla-get-Name x)) ;;; (or (nested_p name) ;;; (setq firstLevelXrefs (cons name firstLevelXrefs)) ;;; ) ;;; (setq nested-xrefs (list name)) ;;; (setq xrefDBase (vl-catch-all-apply 'vla-get-xrefdatabase (list x))) ;;; (or (vl-catch-all-error-p xrefDBase) ;;; (vlax-for xx (vla-get-Blocks xrefDBase) ;;; (if (= (vla-get-isXref xx) :vlax-true) ;;; (setq nested-xrefs (cons (vla-get-Name xx) nested-xrefs)) ;;; ) ;;; ) ;;; ) ;;; (if (cdr nested-xrefs) ;;; (setq nestList (cons (reverse nested-xrefs) nestList)) ;;; ) ;;; ) ;;; ) ;;; ) ;;; (foreach x firstLevelXrefs ;;; (setq i 0) ;;; (build_retlist x) ;;; ) ;;; (reverse retList) ;;; (princ) ;;;) ;;; ;;;(defun c:XrefTree() ;;; (foreach x (XrefTree) ;;; (repeat (* 2 (car x)) (princ " ")) ;;; (princ (cdr x)) ;;; (princ "\n") ;;; ) ;;; (princ) ;;;) ;;; ;Stephan Koster 2002, posted to adesk customization ;;; ; newsgroup on 4/21/2002 (DEFUN XrefTree (/ build_retlist firstLevelXrefs name nested-xrefs nestList xrefDBase retList i ) ;;;****************************************************************************** (DEFUN nested_p (blockname / tn tmp) (AND (SETQ tn (TBLOBJNAME "block" blockname)) (SETQ tmp (ENTGET tn)) (SETQ tmp (CDR (ASSOC 330 tmp))) (SETQ tmp (ENTGET tmp)) (NOT (MEMBER '(102 . "{BLKREFS") tmp)) ) ;_ end of and ) ;_ end of defun ;;;****************************************************************************** (DEFUN build_retlist (name / next) (SETQ retList (CONS (CONS i name) retList)) (AND (SETQ next (CDR (ASSOC name nestList))) (SETQ i (1+ i)) (FOREACH z next (build_retlist z)) (SETQ i (1- i)) ) ;_ end of and ) ;_ end of defun ;;;****************************************************************************** (vlax-for x (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) (if (= (vla-get-isXref x) :vlax-true) (progn (setq name (vla-get-Name x)) (or (nested_p name) (setq firstLevelXrefs (cons name firstLevelXrefs)) ) (setq nested-xrefs (list name)) (setq xrefDBase (vl-catch-all-apply 'vla-get-xrefdatabase (list x))) (or (vl-catch-all-error-p xrefDBase) (vlax-for xx (vla-get-Blocks xrefDBase) (if (= (vla-get-isXref xx) :vlax-true) (setq nested-xrefs (cons (vla-get-Name xx) nested-xrefs)) ) ) ) (if (cdr nested-xrefs) (setq nestList (cons (reverse nested-xrefs) nestList)) ) ) ) ) (FOREACH x firstLevelXrefs (SETQ i 0) (build_retlist x) ) ;_ end of foreach (SETQ keep-retList (REVERSE retList)) (REVERSE retList) ) ;_ end of defun ;;;****************************************************************************** (DEFUN c:XrefTree () (VL-LOAD-COM) (XrefTree) ;;; (FOREACH x (ERRORTRAP (quote (XrefTree))) ;;; (REPEAT (* 2 (CAR x)) (PRINC " ")) ;;; (PRINC (CDR x)) ;;; (PRINC "\n") ;;; ) ;_ end of foreach (PRINC) ) ;_ end of defun ;;;****************************************************************************** (DEFUN FindInList (LstItem Lst) (IF (ASSOC LstItem Lst) (ASSOC LstItem Lst) (WHILE (OR Lst (NOT (ASSOC LstItem Lst)) ) ;_ end of or (SETQ Lst (VL-REMOVE-IF 'NULL (MAPCAR 'CADR Lst ) ;_ end of mapcar ) ;_ end of vl-remove-if ) ;_ end of setq ) ;_ end of while ) ;_ end of if ) ;_ end of defun ;;;****************************************************************************** (DEFUN PrintResults (Lst StrSpace) (FOREACH Item Lst (IF (EQUAL (TYPE Item) 'LIST) (PrintResults Item (STRCAT " " StrSpace)) (PROMPT (STRCAT "\n" StrSpace "|-> Nested Xref = " Item)) ) ;_ end of if ) ;_ end of foreach ) ;_ end of defun ;;;****************************************************************************** ;This code is NOT from Steven Koster ;another person posted it in the forum (DEFUN getXrefNames () (SETQ Doc (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT) ) ;_ end of vla-get-ActiveDocument ) (SETQ BlkCol (VLA-GET-BLOCKS Doc)) (VLAX-FOR Blk BlkCol (IF (= (VLA-GET-ISXREF Blk) :VLAX-TRUE) (SETQ XrefNameList (CONS (LIST (VLA-GET-NAME Blk)) XrefNameList)) ) ;_ end of if ) ;_ end of vlax-for (FOREACH XrefName XrefNameList (VLAX-FOR Obj (VLA-ITEM BlkCol (CAR Xrefname)) (IF (AND (= (VLA-GET-OBJECTNAME Obj) "AcDbBlockReference") (VLAX-PROPERTY-AVAILABLE-P Obj 'Path) ) ;_ end of and (SETQ XrefNameList (SUBST (CONS (CAR XrefName) (CONS (FindInList (VLA-GET-NAME Obj) XrefNameList) (CDR (ASSOC (CAR XrefName) XrefNameList)) ) ;_ end of cons ) ;_ end of cons (ASSOC (CAR XrefName) XrefnameList) (VL-REMOVE-IF '(LAMBDA (x) (= (CAR x) (VLA-GET-NAME Obj))) XrefNameList ) ;_ end of vl-remove-if ) ;_ end of subst ) ;_ end of setq ) ;_ end of if ) ;_ end of vlax-for ) ;_ end of foreach (PRINT XrefNameList) (FOREACH i XrefNameList (PROMPT (STRCAT "\n Main Xref = " (CAR i))) (PrintResults (CDR i) " ") ) ;_ end of foreach ) ;_ end of DEFUN ;;;****************************************************************************** (DEFUN C:xrs-test () (c:xreftree) (SETQ this_dwg (STRCAT (GETVAR "dwgprefix") (GETVAR "dwgname"))) (IF VL-BB-SET NIL (VL-LOAD-COM) ) ;_ end of IF (SETQ zxrs_data (VL-BB-REF 'bb_zxrs_data)) ;recall the last xrswap information saved during this AutoCAD session (IF (AND zxrs_data (DOS_FILEP (CADR zxrs_data)) (EQUAL (CAR zxrs_data) (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME")) ) ;_ end of EQUAL ) ;_ end of AND ;if the last drawing swapped from exists and this drawing equals the drawing last swapped to... (PROGN ;then ask if you want to return to the drawing you came from with this new xrswap call. (SETQ from_drawing (CADR zxrs_data)) (IF debug_stack (PROGN (PRINC "\n1st IF [from_drawing] True! ") (PRINC)) ) ;_ end of IF (SETQ return_query ;0 = YES; 1 = NO (DOS_MSGBOXEX (STRCAT "Return to: " from_drawing ) ;_ end of strcat "AutoCAD" (LIST "Yes" "No") 1 ) ;_ end of dos_msgboxex ) ;_ end of setq ) ;_ end of PROGN (PROGN (IF debug_stack (PROGN (PRINC "\nzxrs_data = ") (PRINC zxrs_data) (PRINC "\n(DOS_FILEP (CADR zxrs_data)) = ") (PRINC (DOS_FILEP (CADR zxrs_data))) (PRINC "\n(CAR zxrs_data)") (PRINC (CAR zxrs_data)) (PRINC "\n(STRCAT (GETVAR \"DWGPREFIX\")(GETVAR \"DWGNAME\")) = " ) ;_ end of PRINC (PRINC (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME"))) (PRINC) ) ;_ end of PROGN ) ;_ end of IF (SETQ return_query 1) ; 1 = NO ) ;_ end of PROGN ) ;_ end of IF (IF vpbnd NIL (LOAD "vpbnd" "\nFile VPBND.LSP not loaded! ") ) ;_ end of IF (IF (EQ return_query 0) ; 0 = YES (PROGN (vpbnd) (IF debug_stack (PROGN (PRINC "\n2nd IF [(EQ return_query 0)] True! ") (PRINC) ) ;_ end of PROGN ) ;_ end of IF (SETQ this_xref_path (IF from_drawing from_drawing (VL-BB-REF 'bb_from_drawing) ) ;_ end of IF ) ;_ end of SETQ (SETQ this_xrswap_drawing (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME") ) ;_ end of STRCAT ) ;_ end of SETQ (isdbmod) (COND ((EQ discard_dwg "No") (SETQ what_to_do 6)) ; savequery = 0; discard_dwg = "No" ((EQ discard_dwg "Yes") (SETQ what_to_do 3)) ; savequery = 1; discard_dwg = "Yes" ((EQ discard_dwg "Cancel") (SETQ what_to_do 1)) ; savequery = 2; discard_dwg = "Cancel" ((EQ discard_dwg "Unmodified") (SETQ what_to_do 0)) ; savequery = 3; discard_dwg = "Unmodified" ) ;_ end of COND (IF myopen_fun NIL (LOAD "myopen_fun" "\nFile MYOPEN_FUN.LSP not loaded! ") ) ;_ end of IF (IF setprevdwg NIL (LOAD "setprevdwg" "\nFile SETPREVDWG.LSP not loaded! ") ) ;_ end of IF (IF c:xreturn NIL (LOAD "next" "\nFile NEXT.LSP not loaded! ") ) ;_ end of IF (COND ((WCMATCH discard_dwg "Cancel") NIL ) ((WCMATCH discard_dwg "Unmodified") ;;; (export_tracking) ;;; (write_xrswap_dat this_xref_path) (setprevdwg) ;;; (myopen_fun this_xref_path) (alert "Open code removed for debugging!") ) ((OR (WCMATCH discard_dwg "Yes") (WCMATCH discard_dwg "No") ) ;_ end of OR ;;; (export_tracking) ;;; (write_xrswap_dat this_xref_path) (setprevdwg) ;;; (myopen_fun this_xref_path) (alert "Open code removed for debugging!") ) ) ;_ end of COND (IF (AND this_drawing (WCMATCH (STRCASE (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME"))) (STRCASE this_drawing) ) ;_ end of WCMATCH ) ;_ end of AND NIL (PROGN (SETQ from_drawing (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME") ) ;_ end of STRCAT ) ;_ end of SETQ (VL-BB-SET 'bb_from_drawing from_drawing) ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN (PROGN (IF ukword nil (LOAD "ukword" "\nFile UKWORD.LSP not loaded! ") ) ;_ end of IF (IF (AND (IF getprevdwg T (LOAD "setprevdwg" nil) ) ;_ end of IF (getprevdwg) (NOT (WCMATCH (STRCASE bb-prev-dwg) (STRCASE (STRCAT (GETVAR "DWGPREFIX") (GETVAR "DWGNAME")) ) ;_ end of STRCASE ) ;_ end of WCMATCH ) ;_ end of NOT (IF c:xreturn T (LOAD "next" nil) ) ;_ end of IF ) ;_ end of AND (SETQ xreturn_or_select (ukword 1 "Return Select Quit" "What Xrswap action do you want? [Return/Select/Quit]" "Select" ) ;_ end of ukword ) ;_ end of SETQ (SETQ xreturn_or_select "Select") ) ;_ end of IF (COND ((EQ xreturn_or_select "Return") (SETQ xreturn_or_select NIL) (C:XRETURN) ) ((EQ xreturn_or_select "Quit") nil ) ((EQ xreturn_or_select "Select") (IF (AND (SETQ elst (NENTSEL "\nSelect xref: ")) (SETQ lastlst (LAST elst)) (= (TYPE (CAR lastlst)) 'ENAME) (SETQ blk (VLAX-ENAME->VLA-OBJECT (CAR lastlst))) (SETQ blkname (VLAX-GET blk 'Name)) (= :VLAX-TRUE (VLA-GET-ISXREF (SETQ blkitem (VLA-ITEM (VLA-GET-BLOCKS (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT) ) ;_ end of vla-get-ActiveDocument ) ;_ end of vla-get-Blocks blkname ) ;_ end of vla-item ) ;_ end of vla-item ) ;_ end of vla-get-IsXref ) ;_ end of = (SETQ xref-was-selected T) ) ;_ end of and (PROGN (IF C:SHOWKEYS NIL (LOAD "LAMACS" "\nFile LAMACS.LSP not loaded! ") ) ;_ end of IF (C:SHOWKEYS) (vpbnd) (SETQ xrswap_dlg# (LOAD_DIALOG "xrswap")) (SETQ newdlg_xrswap (NEW_DIALOG "xrswap" xrswap_dlg# (IF defact_xrswap defact_xrswap "" ) ;_ end of IF (IF xrswap_loc xrswap_loc '(-1 -1) ) ;_ end of IF ) ;_ end of NEW_DIALOG ) ;_ end of SETQ (IF errmsg (SET_TILE "error" errmsg) (SET_TILE "error" "") ) ;_ end of IF (c:xreftree) (IF (member blkname (mapcar '(lambda (x) (nth 1 x)) (reverse keep-retlist))) (setq select-ndx (ITOA (1-(length (member blkname (mapcar '(lambda (x) (nth 1 x)) (reverse keep-retlist))))))) (setq select-ndx NIL) ) (SETQ fullpath-xreflist (MAPCAR '(LAMBDA (x) (DOS_FULLPATH (STRCAT (GETVAR "DWGPREFIX") (NTH 2 x) ) ;_ end of STRCAT ) ;_ end of DOS_FULLPATH ) ;_ end of LAMBDA keep-retList ) ;_ end of MAPCAR ) ;_ end of setq (START_LIST "xrswap-ndx") (MAPCAR 'ADD_LIST fullpath-xreflist) (END_LIST) (IF select-ndx (PROGN (SETQ xrswap-ndx select-ndx) (SET_TILE "xrswap-ndx" xrswap-ndx) ) ) (ACTION_TILE "xrswap-ndx" "(setq xrswap-ndx (get_tile \"xrswap-ndx\"))" ) ;_ end of ACTION_TILE (ACTION_TILE "accept" "(SETQ xrswap_loc(done_dialog 1))") (ACTION_TILE "cancel" "(SETQ xrswap_loc(done_dialog 2))") (SETQ xrswap-return (START_DIALOG)) (IF xrswap-ndx NIL (SETQ xrswap-ndx (GET_TILE "xrswap-ndx"))) (IF (AND xrswap-ndx (EQ xrswap-return 1)) (PROGN (SETQ xref-path (NTH (ATOI xrswap-ndx) fullpath-xreflist) ) ;_ end of SETQ ;;; (alert "Open code removed for debugging!") (isdbmod) (xrswap-open xref-path) ) ;_ end of progn ) ;_ end of if ) ;_ end of PROGN ) ;_ end of IF (UNLOAD_DIALOG xrswap_dlg#) (SETQ xrswap_dlg# nil) ) ) ;_ end of COND ) ;_ end of PROGN ) ;_ end of IF (PRINC) ) ;_ end of DEFUN ;;;****************************************************************************** (DEFUN isdbmod () (IF (> (GETVAR "dbmod") 0) (SETQ savequery (DOS_MSGBOXEX ;0 = YES; 1 = NO (STRCAT "Save changes to: " (GETVAR "dwgprefix") (GETVAR "dwgname") ) ;_ end of strcat "AutoCAD" (LIST "Yes" "No" "Cancel") 1 ) ;_ end of dos_msgboxex ) ;_ end of setq (SETQ savequery 3) ) ;_ end of if (COND ((EQ savequery 0) (SETQ discard_dwg "No" what_to_do 6 ;Yes, save changes ) ;_ end of SETQ ) ((EQ savequery 1) (SETQ discard_dwg "Yes" what_to_do 3 ;No, do not save changes ) ;_ end of SETQ ) ((EQ savequery 2) (SETQ discard_dwg "Cancel" what_to_do 1 ;Cancel the command ) ;_ end of SETQ ) ((EQ savequery 3) (SETQ discard_dwg "Unmodified" what_to_do 0 ;Open without answering "Save?" question ) ;_ end of SETQ ) ) ;_ end of COND (PRINC) ) ;_ end of DEFUN ;;;****************************************************************************** (DEFUN xrswap-open (file) (COND ((OR(EQ savequery 0)(EQ savequery 1)) (COMMAND ".open" discard_dwg file)) ((EQ savequery 2) NIL) ((EQ savequery 3) (COMMAND ".open" file)) ) (PRINC) ) ;;;****************************************************************************** (DEFUN C:ZXRS () (IF (AND min_x_val min_y_val max_x_val max_y_val ) ;_ end of AND (PROGN (COMMAND ".zoom" "w" (LIST min_x_val min_y_val) (LIST max_x_val max_y_val) ) ;_ end of COMMAND ) (PROGN (PRINC "\nNo viewport boundary points have been located! ") (PRINC) ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of DEFUN ;;;****************************************************************************** (DEFUN debug-lines (int) (IF debug (PROGN (PRINC "\n") (PRINC int) (PRINC "\n") (PRINC) 'T ) 'T ) ) ;;;****************************************************************************** ;|«Visual LISP© Format Options» (72 2 40 2 T "end of " 60 9 2 0 0 nil T nil T) ;*** DO NOT add text below the comment! ***|;