外部参照-在VBA区分“已卸载”和“未找到”

Option Explicit
Public Enum XRefStatus
  xrloaded = 1
  xrdetached = 2
  xrNotFound = 3
End Enum
Public Sub test()
  Dim colBlocks As AcadObject
  Dim objBlock As AcadBlock
  Dim objXRefDbase1 As AcadDatabase
  Dim objXRefDbase2 As AcadDatabase
  Dim objXref As AcadExternalReference
  Dim varXref() As Variant
  Dim intCount As Integer
  
  
  Set colBlocks = Me.Blocks
    For Each objBlock In colBlocks
      If objBlock.IsXRef Then
        Select Case GetXRefStatus(objBlock)
          Case 1 'xrloaded
            MsgBox "Xref " & objBlock.Name & " is Loaded"
          Case 2 'xrdetached
            MsgBox "Xref " & objBlock.Name & " is Detached"
          Case 3 'xrnotfound
            MsgBox "Xref " & objBlock.Name & " was not found"
          Case Else
            MsgBox "Xref " & objBlock.Name & " has me confused"
        End Select
      End If
    Next objBlock
    
  
  
  
End Sub
Public Function GetXRefStatus(pXRef As AcadBlock) As XRefStatus
  Dim xStatus As XRefStatus
  Dim objTestObj As Object
  
  On Error GoTo XRefStatus_Error
    
  If pXRef.Count > 1 Then
    GetXRefStatus = xrloaded
    Exit Function
  End If
  
  If pXRef.Count = 1 Then
    If pXRef(0).ObjectName = "AcDbText" Then
      If pXRef(0).TextString Like "*" & pXRef.Name & "*" Then
        GetXRefStatus = xrNotFound
        Exit Function
      Else ' it only has one item, and that item is text
        GetXRefStatus = xrloaded
        Exit Function
      End If
    Else ' it only has one object in it, but that item isnt text
      GetXRefStatus = xrloaded
      Exit Function
    End If
  End If
  
  If pXRef.Count = 0 Then 'either unloaded or empty xref
    'unloaded xrefs have no database so this will raise an error
    Set objTestObj = pXRef.XRefDatabase
    GetXRefStatus = xrloaded ' if it gets to here, then the xref is attached but
    Exit Function            ' contains no objects
  End If
  
XRefStatus_Error:
  Select Case Err.Number
    Case -2145386390 ' no database error
      GetXRefStatus = xrdetached
      Err.Clear
      Exit Function
    Case Else
      MsgBox Err.Number
      Debug.Print "Error " & Err.Number
      Err.Clear
      Exit Function
  End Select
End Function

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