[原创]尺寸线块有多少个子块统计？

Function FixDimText(Dimension As AcadDimension) As String
    '在复制标注对象前先保存当前图形中的块数量
    Dim xlSheet As Worksheet
    Set xlSheet = ReturnxlSheet
    Dim ii As Integer
    
    Dim BlockCount As Long
''
''
    BlockCount = ThisDrawing.Blocks.Count
    With xlSheet
      ii = .Range("A65536").End(xlUp).Row + 2
    End With    '复制需要锁定文字内容的标注对象
    
    '检查块数量是否增加，而且新增加的块名前缀是否为"*D"
    Dim NewBlockCount As Long
    Dim CopyDimension As AcadDimension
    Set CopyDimension = Dimension.Copy
    
    NewBlockCount = ThisDrawing.Blocks.Count
    
    
    
    If NewBlockCount = BlockCount + 1 And Left(ThisDrawing.Blocks(BlockCount).Name, 2) = "*D" Then
    
        '遍历块中的对象，取得文字内容
        Dim EntityInBlock As AcadEntity
        For Each EntityInBlock In ThisDrawing.Blocks(BlockCount)
    With EntityInBlock
      
'
      xlSheet.Cells(ii, 1) = Dimension.ObjectName
      xlSheet.Cells(ii, 2) = Dimension.Handle
      xlSheet.Cells(ii, 3) = Dimension.TextOverride
      xlSheet.Cells(ii, 4) = BlockCount
      xlSheet.Cells(ii, 5) = CopyDimension.ObjectName
      xlSheet.Cells(ii, 6) = CopyDimension.Handle
      xlSheet.Cells(ii, 7) = Dimension.TextOverride
      xlSheet.Cells(ii, 8) = NewBlockCount
'
      xlSheet.Cells(ii, 9) = .ObjectName
      xlSheet.Cells(ii, 10) = .Handle
      xlSheet.Cells(ii, 11) = ThisDrawing.Blocks(BlockCount).Name
      xlSheet.Cells(ii, 12) = ThisDrawing.Blocks(BlockCount).Count
      ii = ii + 1
    
      'Debug.Print .ObjectName, .Handle, BlockCount,
    End With
            If EntityInBlock.ObjectName = "AcDbMText" Then
                '将文字内容替换掉标注对象的文字内容
                Dimension.TextOverride = EntityInBlock.TextString
                'Exit For
            End If
        Next
    End If
    '删除复制的标注对象
    CopyDimension.Delete
    FixDimText = Dimension.TextOverride
End Function'将图形中所有的标注对象锁定文字内容
Sub FixAllDim()
'
    Dim xlSheet As Worksheet
    Set xlSheet = ReturnxlSheet
    xlSheet.Range("a:z").ClearContents
'
    
    Dim SSet As AcadSelectionSet
    On Error Resume Next
    '建立选择集
    ThisDrawing.SelectionSets("mccad").Delete
    Set SSet = ThisDrawing.SelectionSets.Add("mccad")
    '建立过滤器
    Dim fType(0) As Integer
    Dim fData(0) As Variant
    fType(0) = 0
    fData(0) = "DIMENSION"
    '选择过滤出图形中所有的标注对象
    SSet.Select acSelectionSetAll, , , fType, fData
    Dim i As Long
    For i = 0 To SSet.Count - 1
        '锁定标注的文字内容
        FixDimText SSet(i)
    Next
End Sub