Here is one that works. Be careful and test it first. My setup here seems to crash when I use the xref command after, but not when I use ".xref", so I'm thinking it is something with my Acad setup. Let me know what happens.
What I fixed was soemthing I saw in a code by Joe Burke. When he got the answer (matrix) from the function "ObjMatrix" he turned it into a variant, and then passed the variant to (vla-transformedby.... , and that seemed to work here also. Make sure you have the lisps that he provided loaded, or it will error.
Thanks Joe.
(defun c:Xrefs2Block (/ ActDoc BlkCol LayCol Message NewBlkName ss Ent EntData BlkName BlkRefObj XrefList dbxApp
LayList ObjList FullPath NewBlk NewObjList LayToLock XrefObj)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq BlkCol (vla-get-Blocks ActDoc))
(setq LayCol (vla-get-Layers ActDoc))
(setq Message "\n Enter block name: ")
(if
(and
(while
(or
(not NewBlkName)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list BlkCol NewBlkName))))
)
(not (while (= (setq NewBlkName (getstring T Message)) "")))
(setq Message "\n Block name already exist, please type another: ")
)
(setq ss (ssget '((0 . "INSERT"))))
)
(progn
(while (setq Ent (ssname ss 0))
(and
(setq EntData (entget Ent))
(setq BlkName (cdr (assoc 2 EntData)))
(setq BlkRefObj (vla-item BlkCol BlkName))
(= (vla-get-IsXref BlkRefObj) :vlax-true)
(setq XrefList (cons Ent XrefList))
)
(ssdel Ent ss)
)
(setq dbxApp
(if (< (atoi (setq oVer (substr (getvar "acadver") 1 2))) 16)
(vla-GetInterfaceObject (vlax-get-acad-object) "ObjectDBX.AxDbDocument")
(vla-GetInterfaceObject (vlax-get-acad-object) (strcat "ObjectDBX.AxDbDocument." oVer))
)
)
(foreach Ename XrefList
(setq BlkName (cdr (assoc 2 (entget Ename))))
(setq XrefObj (vlax-ename->vla-object Ename))
(vlax-for i LayCol
(if
(and
(wcmatch (setq LayName (vla-get-Name i)) (strcat BlkName "|*"))
(= (vla-get-LayerOn i) :vlax-true)
(= (vla-get-Freeze i) :vlax-false)
)
(setq LayList (cons (substr LayName (+ 2 (strlen BlkName))) LayList))
)
)
(if (not NewBlk)
(setq NewBlk (vlax-invoke BlkCol 'Add '(0.0 0.0 0.0) NewBlkName))
)
(if (setq FullPath (findfile (vla-get-Path XrefObj)))
(progn
(vla-Open dbxApp FullPath)
(vlax-for i (vla-get-ModelSpace dbxApp)
(if (vl-position (vla-get-Layer i) LayList)
(setq ObjList (cons i ObjList))
)
)
(setq NewObjList (vlax-invoke dbxApp 'CopyObjects ObjList NewBlk))
(foreach Lay LayList
(if
(and
(not (vl-catch-all-error-p (setq LayObj (vl-catch-all-apply 'vla-Item (list LayCol Lay)))))
(= (vla-get-Lock LayObj) ':vlax-true)
)
(progn
(vla-put-Lock LayObj :vlax-false)
(setq LayToLock (cons LayObj LayToLock))
)
)
)
(foreach i NewObjList
(vla-TransformBy i (vlax-tmatrix (ObjMatrix XrefObj)))
)
(mapcar 'vlax-release-object NewObjList)
(vlax-release-object XrefObj)
(setq NewObjList nil)
(foreach Lay LayToLock
(vla-put-Lock Lay :vlax-true)
)
(setq LayToLock nil)
)
(prompt (strcat "\n Can not find \"" FullPath "\" drawing to open."))
)
(setq LayList nil)
(setq ObjList nil)
)
(if NewBlk
(vlax-invoke (vla-get-Block (vla-get-ActiveLayout ActDoc)) 'InsertBlock '(0.0 0.0 0.0) (vla-get-Name NewBlk) 1.0 1.0 1.0 0.0)
)
(vlax-release-object dbxApp)
(setq dbxApp nil)
)
)
(princ)
)
ps. Forgot to tell you, this will insert the block also.