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

兰州人

尺寸实体名(块)尺寸块内的子实体个数AcDb2LineAngularDimension15AcDb2LineAngularDimension15AcDb2LineAngularDimension14AcDbRotatedDimension14AcDb2LineAngularDimension13AcDbRotatedDimension11AcDb2LineAngularDimension11AcDbAlignedDimension11AcDbRotatedDimension10AcDb2LineAngularDimension10AcDbRotatedDimension9AcDb2LineAngularDimension9AcDbDiametricDimension8AcDbRotatedDimension7AcDbRadialDimension6AcDbDiametricDimension6AcDbRadialDimension5
原程序是在AutoCAD二次开发p127页基础上改动的。

2. Function FixDimText(Dimension As AcadDimension) As String
3.     '在复制标注对象前先保存当前图形中的块数量
4.     Dim xlSheet As Worksheet
5.     Set xlSheet = ReturnxlSheet
6.     Dim ii As Integer
7.    
8.     Dim BlockCount As Long
9. ''
10. ''
11.     BlockCount = ThisDrawing.Blocks.Count
12.     With xlSheet
13.       ii = .Range("A65536").End(xlUp).Row + 2
14.     End With
16.     '复制需要锁定文字内容的标注对象
17.    
18.     '检查块数量是否增加，而且新增加的块名前缀是否为"*D"
19.     Dim NewBlockCount As Long
20.     Dim CopyDimension As AcadDimension
21.     Set CopyDimension = Dimension.Copy
22.    
23.     NewBlockCount = ThisDrawing.Blocks.Count
24.    
25.    
26.    
27.     If NewBlockCount = BlockCount + 1 And Left(ThisDrawing.Blocks(BlockCount).Name, 2) = "*D" Then
28.    
29.         '遍历块中的对象，取得文字内容
30.         Dim EntityInBlock As AcadEntity
31.         For Each EntityInBlock In ThisDrawing.Blocks(BlockCount)
32.     With EntityInBlock
33.       
34. '
35.       xlSheet.Cells(ii, 1) = Dimension.ObjectName
36.       xlSheet.Cells(ii, 2) = Dimension.Handle
37.       xlSheet.Cells(ii, 3) = Dimension.TextOverride
38.       xlSheet.Cells(ii, 4) = BlockCount
39.       xlSheet.Cells(ii, 5) = CopyDimension.ObjectName
40.       xlSheet.Cells(ii, 6) = CopyDimension.Handle
41.       xlSheet.Cells(ii, 7) = Dimension.TextOverride
42.       xlSheet.Cells(ii, 8) = NewBlockCount
43. '
44.       xlSheet.Cells(ii, 9) = .ObjectName
45.       xlSheet.Cells(ii, 10) = .Handle
46.       xlSheet.Cells(ii, 11) = ThisDrawing.Blocks(BlockCount).Name
47.       xlSheet.Cells(ii, 12) = ThisDrawing.Blocks(BlockCount).Count
48.       ii = ii + 1
49.    
50.       'Debug.Print .ObjectName, .Handle, BlockCount,
51.     End With
52.             If EntityInBlock.ObjectName = "AcDbMText" Then
53.                 '将文字内容替换掉标注对象的文字内容
54.                 Dimension.TextOverride = EntityInBlock.TextString
55.                 'Exit For
56.             End If
57.         Next
58.     End If
59.     '删除复制的标注对象
60.     CopyDimension.Delete
61.     FixDimText = Dimension.TextOverride
62. End Function
64. '将图形中所有的标注对象锁定文字内容
65. Sub FixAllDim()
66. '
67.     Dim xlSheet As Worksheet
68.     Set xlSheet = ReturnxlSheet
69.     xlSheet.Range("a:z").ClearContents
70. '
71.    
72.     Dim SSet As AcadSelectionSet
73.     On Error Resume Next
74.     '建立选择集
75.     ThisDrawing.SelectionSets("mccad").Delete
76.     Set SSet = ThisDrawing.SelectionSets.Add("mccad")
77.     '建立过滤器
78.     Dim fType(0) As Integer
79.     Dim fData(0) As Variant
80.     fType(0) = 0
81.     fData(0) = "DIMENSION"
82.     '选择过滤出图形中所有的标注对象
83.     SSet.Select acSelectionSetAll, , , fType, fData
84.     Dim i As Long
85.     For i = 0 To SSet.Count - 1
86.         '锁定标注的文字内容
87.         FixDimText SSet(i)
88.     Next
89. End Sub

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