;;;  ;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! ***|;