[编程交流] 外部参照重新关联问题（

Private Function GetXrefPath() As String
'------------------------------------------------------------------------------
'
'Returns:   XREF drawing path i.e. "SomeDrawing.dwg"
'Caveats:   Assuming no nested xrefs and only one per drawing
'------------------------------------------------------------------------------
Dim acXref As AcadExternalReference
Dim acSS As AcadSelectionSet
Dim acBlks As AcadBlocks
Dim acBlk As AcadBlock
Dim acEnt As AcadEntity
Dim sPath As String
Dim sEntType As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler
sEntType = "INSERT"
Set acSS = GetEntitySS(sEntType)
Set acBlks = ThisDrawing.Blocks
For Each acEnt In acSS
   Set acBlk = acBlks(acEnt.Name)
   If acBlk.IsXRef Then
       Set acXref = acEnt
       sPath = acXref.Path
       Exit For
   End If
Next acEnt
GetXrefPath = sPath
ExitHere:
   Exit Function
ErrHandler:
   Debug.Print Err.Number, Err.description, "Function 'GetXrefPath' Failed"
End Function