[原创]尺寸线块有多少个子块统计？
尺寸实体名(块)尺寸块内的子实体个数AcDb2LineAngularDimension15AcDb2LineAngularDimension15AcDb2LineAngularDimension14AcDbRotatedDimension14AcDb2LineAngularDimension13AcDbRotatedDimension11AcDb2LineAngularDimension11AcDbAlignedDimension11AcDbRotatedDimension10AcDb2LineAngularDimension10AcDbRotatedDimension9AcDb2LineAngularDimension9AcDbDiametricDimension8AcDbRotatedDimension7AcDbRadialDimension6AcDbDiametricDimension6AcDbRadialDimension5原程序是在autocad二次开发p127页基础上改动的。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
页:
[1]