计算dwg中的外部参照

Public Sub PMS_Xref_Extract()
      Dim ss As AcadSelectionSet, intType(0 To 1) As Integer, varData(0 To 1) As Variant
      Dim objBlkXref As AcadExternalReference, strAssemblyName As String
            
      Erase SN
      Erase CNT
      ACADSelSet ss, "AssemblyCount"
      intType(0) = 0: varData(0) = "INSERT"
      intType(1) = 2: varData(1) = "SC-*"
      ss.Select Mode:=acSelectionSetAll, filtertype:=intType, filterdata:=varData
      
      For Each objBlkXref In ss
            If objBlkXref.Layer = "3D-CONSTRUCTION" Then
                  strAssemblyName = objBlkXref.EffectiveName
                  IncrimentCount strAssemblyName
            End If
      Next
      Dim fso, fl, fln, s
      Dim j As Integer
      fln = "M:\PARTS-LIST\PMS.txt"
      Set fso = CreateObject("Scripting.FileSystemObject")
      If fso.FileExists(fln) Then
            fso.DeleteFile fln
      End If
      Set fl = fso.CreateTextFile(fln)
      For j = 1 To UBound(SN)
            s = CNT(j) & vbTab & SN(j)
            fl.WriteLine s
      Next
      fl.Close
End Sub

Option Explicit
Private colXrefs As New Collection
Private Sub Class_Initialize()
  'When the class is created
  Call LoadXrefs
End Sub
Private Sub LoadXrefs()
  Dim objSelSets As AcadSelectionSets
  Dim objSelSet As AcadSelectionSet
  Dim intType(0) As Integer
  Dim varData(0) As Variant
  Dim strPaths() As String
  Dim intCnt As Integer
  Dim objXref As AcadExternalReference
  Dim objEnt As AcadEntity
  Dim objBlk As AcadBlock
  Dim objBlks As AcadBlocks
  Dim intDuplicate As Integer
  Dim objDuplicate As AcadEntity
  Dim boolDuplicate As Boolean
  
  Set objBlks = ThisDrawing.Blocks
  Set objSelSets = ThisDrawing.SelectionSets
  For Each objSelSet In objSelSets
    If objSelSet.Name = "GetXrefPaths" Then
      objSelSets.Item("GetXrefPaths").Delete
      Exit For
    End If
  Next
  Set objSelSet = objSelSets.Add("GetXrefPaths")
  intType(0) = 0: varData(0) = "INSERT"
  objSelSet.Select acSelectionSetAll, , , intType, varData
  For Each objEnt In objSelSet
    Set objBlk = objBlks(objEnt.Name)
    If objBlk.IsXRef Then
      boolDuplicate = False
      For intDuplicate = 1 To colXrefs.Count
        Set objDuplicate = colXrefs.Item(intDuplicate)
        If objDuplicate.Name = objEnt.Name Then
          boolDuplicate = True
          Exit For
        End If
      Next intDuplicate
      If boolDuplicate = False Then
        colXrefs.Add objEnt '.Path
        GetNested objBlk
      End If
    End If
  Next objEnt
End Sub
Private Function GetNested(objBlk As AcadBlock) As Integer
  Dim objXref As AcadExternalReference
  Dim objBlkRef As AcadBlockReference
  Dim objEnt As AcadEntity
  Dim objNext As AcadBlock
    For Each objEnt In objBlk
      If TypeOf objEnt Is AcadBlockReference Then
        Set objBlkRef = objEnt
        Set objNext = ThisDrawing.Blocks(objBlkRef.Name)
        If objNext.IsXRef Then
          Set objXref = objEnt
          colXrefs.Add objXref
          GetNested objNext
        End If
      End If
    Next
  GetNested = colXrefs.Count
End Function
'Returns the stored Xref at Index
Public Property Get Item(Index As Integer) As AcadExternalReference
  Set Item = colXrefs(Index)
End Property
'How many in the drawing (includes nested)
Public Property Get Count() As Integer
  Count = colXrefs.Count
End Property