[编程交流] 自动绑定多个图形

Public Function BindXrefs()
'------------------------------------------------------------------------------
'Binds Xrefs to drawing without prefix
'Delete Xref from drawing and then insert file and explode it
'------------------------------------------------------------------------------
Dim acBlkRef As AcadBlockReference
Dim sXref As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler
sXref = GetXrefPath
If sXref <> "" Then
   sXref = dhTrimLeft(sXref, "", True, -1) 'Remove path info
   sXref = dhTrimRight(sXref, ".") 'Remove .dwg extension
   ThisDrawing.SendCommand "-XREF" & vbCr & "D" & vbCr & sXref & vbCr
   ThisDrawing.PurgeAll
   sXref = sXref & ".dwg"
   acBlkRef = InsertBlkRef(sXref)
   Set acBlkRef = Nothing
End If
   
ExitHere:
   Exit Function
ErrHandler:
   Debug.Print Err.Number, Err.description, "Function 'BindXrefs' Failed"
End Function
Private Function GetXrefPath() As String
'------------------------------------------------------------------------------
'
'Returns:   XREF drawing path i.e. "1000-01_01.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