What a great way to spend a few rainy hours!! Sure beats working.
Here is a VBA routine thats uses the 70 and 71 codes for xref status. It requires a rereference to the VLisp ActiveX Module (vl16.tlb for version 2004, 2005, 2006, in the AutoCAD installation folder. On my computer, anyway. You may have to search for it)
I haven't fully tested it, but it appears to work in the testing that I have done.
Public Sub XRefTest2()
Dim colBlocks As AcadObject
Dim objBlock As AcadBlock
Dim testBlock As AcadObject
Dim Flag70 As Variant
Dim Flag71 As Variant
Dim sHandle1 As String
Dim sHandle2 As String
Dim sBlockName As String
Set colBlocks = Me.Blocks
For Each objBlock In colBlocks
If objBlock.IsXRef Then
sHandle1 = "&H" + objBlock.Handle
sBlockName = objBlock.Name
sHandle2 = Hex(sHandle1 + 1)
Set testBlock = ThisDrawing.HandleToObject(sHandle2)
Flag70 = vbAssoc(testBlock, 70)
Flag71 = vbAssoc(testBlock, 71)
If Flag71 = "1" Then
MsgBox sBlockName & " appears to be UNLOADED "
ElseIf (Val(Flag70) And 32) = 32 Then MsgBox sBlockName & " appears to be LOADED and RESOLVED "
ElseIf (Val(Flag70) And 4) = 4 Then MsgBox sBlockName & " appears to be NOT FOUND "
End If
End If
Next objBlock
End Sub
Public Function vbAssoc(pAcadObj As AcadObject, pDXFCode As Integer) As Variant
Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant
Dim obj1 As Object
Dim obj2 As Object
Dim strHnd As String
Dim strVer As String
Dim lngCount As Long
Dim i As Long
Dim j As Long
On Error GoTo vbAssocError
strHnd = pAcadObj.Handle
If Me.Application.Version = "16.0" Then
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Else
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
End If
Set VLispFunc = VLisp.ActiveDocument.Functions
Set obj1 = VLispFunc.Item("read").funcall("pDXF")
varRetVal = VLispFunc.Item("set").funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").funcall("pHandle")
varRetVal = VLispFunc.Item("set").funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
vbAssoc = varRetVal
'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").funcall("(setq pDXF nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
Set obj1 = VLispFunc.Item("read").funcall("(setq pHandle nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
'release the objects or Autocad gets squirrely
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function
vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
MsgBox "Error occurred " & Err.Description
End Function
It might be overkill, but playing with it sure was fun