Blocks to Xrefs converter problem

[igal1971]

This lisp works properly in acad 2000 but in 2013 and above have no functionality. I don't now how to fix it.. Probably anybody nows?

(defun c:btx () (c:BlockToXref))
(defun c:BlockToXref (/            errexit      undox
                      olderr       restore      errexitA2k
                      ss ss1 e1 ix path
                      bsl bn bnl bl bt not_ok repl oldvport oldregenmode
                      typ ed layer color ltype ang ins tab oldtab
                     )
  (defun errexit (s)
    (princ "\nError:  ")
    (princ s)
    (restore)
  )

  (defun undox ()
    (setq ss1 nil)
    (setq ss2 nil)
    (setvar "ctab" oldtab)
    (if (> oldcvport 1) (command "._mspace") (command "._pspace"))
    (setvar "cvport" oldcvport)
    (setvar "regenmode" oldregenmode)
    (command "._undo" "_E")
    (setvar "cmdecho" oldcmdecho)
    (setq *error* olderr)
    (princ)
  )

  (setq olderr  *error*
        restore undox
        *error* errexit
  )
  (setq oldcmdecho (getvar "cmdecho"))
  (setq oldtab (getvar "ctab"))
  (setq oldcvport (getvar "cvport"))
  (setq oldregenmode (getvar "regenmode"))
  (setvar "cmdecho" 0)
  (setvar "regenmode" 0)
  (command "._UNDO" "_BE")
  (setq A2k (wcmatch (getvar "ACADVER") "15*"))
  (if (and A2k (/= (setq ss1 (ssget '((0 . "INSERT")))) nil))
    (progn
      (vl-load-com)
      (setq ix 0)
      (setq bsl nil) ; block selection list
      (setq bnl nil) ; unique block name list
      (repeat (sslength ss1)
        (setq e1 (ssname ss1 ix))
        (setq bn (cdr (assoc 2 (entget e1)))) ; block name
        (setq bl (tblsearch "block" bn)) ; block list bn
        (setq bt (cdr (assoc 70 bl))) ; block type
        (if (and (/= (logand bt 4) 4) (not (member bn bnl))) ; no xrefs and no duplicates
           (setq bnl (cons bn bnl))
        )
        (setq ix (1+ ix))
      ); end repeat

      (foreach bn bnl
        (setq ss1 (ssget "X" (list (cons 0 "INSERT") (cons 2 bn))))
        (setq ix 0)
        (repeat (sslength ss1)
          (setq e1 (ssname ss1 ix))
          (setq bsl (cons (entget e1) bsl))
          (setq ix (1+ ix))
        )
      ); end repeat

      (foreach bn bnl
        (setq not_ok T)
        (while not_ok
          (setq path (getfiled "Match the block to a file"
                               (if (not path) (strcat (getvar "dwgprefix") bn) (strcat (vl-filename-directory path) "\\" bn))
                               "dwg" 0))
          (if path
            (if (= (strcase (vl-filename-base  path)) (strcase bn))
              (setq not_ok nil)
              (progn
                (initget 0 "Yes No")
                (setq repl (getkword "\nAssign a different name? [Yes/No] : "))
                (if (not repl) (setq repl "Yes"))
                (if (= "Yes" repl)
                  (setq not_ok nil)
                  (setq not_ok T)
                )
              )        
            )
          )
          (if (not not_ok)
            (progn
              (setq ss (ssget "X" (list (cons 0 "INSERT") (cons 2 bn))))
              (setq ix 0)
              (repeat (sslength ss)
                (setq ed (ssname ss ix))
                (setq tab (cdr (assoc 410 (entget ed))))
                (setvar "ctab" tab)
                (entdel ed)
                (setq ix (1+ ix))
              )
              (repeat 10
                (vl-cmdf "._purge" "_b" "*" "N")
              )
              (initget 0 "Overlay Attach")
              (setq repl (getkword "\nEnter an option [Overlay/Attach] : "))
              (if (not repl) (setq repl "Attach"))
              (if (= "Attach" repl) (setq typ "_A") (setq typ "_O"))
              (setq ix 0)
              (repeat (length bsl)
                (setq ed (nth ix bsl))
                (if (= bn (cdr (assoc 2 ed)))
                  (progn
                    (setq layer (cdr (assoc 8 ed)))
                    (setq color (cdr (assoc 62 ed)))
                    (if (not color) (setq color "_ByLayer"))
                    (setq ltype (cdr (assoc 6 ed)))
                    (if (not ltype) (setq ltype "_ByLayer"))
                    (setq ang (/ (* 180.0 (cdr (assoc 50 ed))) pi))
                    (setq ins (cdr (assoc 10 ed)))
                    (setq tab (cdr (assoc 410 ed)))
                    (setvar "ctab" tab)
                    (if (/= tab "Model") (command "._pspace"))
                    (vl-cmdf "._xref" typ path "_X" (cdr (assoc 41 ed)) "_Y" (cdr (assoc 42 ed)) "_Z" (cdr (assoc 43 ed)) ins ang)
                    (vl-cmdf "._change" "_L" "" "_P" "_C" color "_LA" layer "_LT" ltype "")
                  )
                )
                (setq ix (1+ ix))
              )
            )
          )
          (if (= path nil) (setq not_ok nil))
        )
      )
    ); end progn
  ); end if
  (restore)
)

[hmsilva]

igal1971,

firstly, it's not polite to remove the header from the codes you post.

Second, you are posting copyrighted material, without at least, a link to the original place where you found it and credits to the author.

From your bio (I understand you develop) 'CAD software applications design by AUTOLISP', therefore, should be easy for you to identify the reason why the code does not work in AC2013.

Try to contact the author, I think Jimmy Bergmark will help you in that one...

Henrique

[igal1971]

Diar Henrique!

I am very sorry for the inconvenience but I do not feel guilty because I found the lisp in the following form:

http://www.cad.dp.ua/sovets/lisp-functions/BlockToXref.php

As you see you have not any remembering to copyright here..

so why are you accusing me for that I did not do?

Is it polite?

[igal1971]

Anyway, I propose to be constructive and declare: It's not so easy for me to identify the reason why the code does not work in AC2013. If somebody nows a solution please share!

[hmsilva]

---

@igal1971 wrote:

...

I am very sorry for the inconvenience but I do not feel guilty because I found the lisp in the following form:

http://www.cad.dp.ua/sovets/lisp-functions/BlockToXref.php 

As you see you have not any remembering to copyright here..

so why are you accusing me for that I did not do?

Is it polite?

---

igal1971,

yes it is,

as I have said, post a link to the original place where you found it,  if you had done that in your first post, I would have said,

the code you post is copyrighted material, and the header was removed...

Henrique

[igal1971]

header was removed... but not by me!! This is not my crime! Do you understand it? Why you continue to accusing me?

[hmsilva]

---

@igal1971 wrote:
header was removed... but not by me!! This is not my crime! Do you understand it? Why you continue to accusing me?

---

You're not understanding me.

What I have said in my previous post, was:

the code you post is copyrighted material, and the header was removed...

Means:

You posted the code here,

then I'm saying (alerting you) that the code is copyrighted material, and the header was removed in the link you did provided.

That's why we should provide a link to the place where we find the posted code.

Henrique

[igal1971]

.. and some words about a copyright. This is what I thik about it. Let's see what Jimmy Bergmark wrote about it in his site:
http://www.jtbworld.com/lisp/blocktoxref.htm
Jimmy Bergmark wrote : "Copyright (C) 1997-2006 JTB World, All Rights Reserved"
It's mean copyright until 2006 and now 2014
Conclusion: This is not copyrighted material!

[JTBWorld · Accepted solution]

As far as I know "Copyright (C) 1997-2006 JTB World, All Rights Reserved" just means that the file was updated last in 2006 but the copyright still applies. But no worry. I've updated the code to work with newer versions of AutoCAD.

http://www.jtbworld.com/lisp/blocktoxref.htm

[igal1971]

I am not worry This is your lisp Jimmy not my:)
Probably in US ""Copyright (C) 1997-2006 JTB World, All Rights Reserved" just means that the file was updated last in 2006 but the copyright still applies" but as iknow in Western Europe and most arab countries it means different, but this is not a place to argue about it. You are Right! That All Folks:)