尺寸线复制给块，获得AcDbMtext
本帖最后由 作者 于 2009-2-9 19:14:26 编辑对于尺寸图元 dim objDim as AcadDimension
debug.printobjDim.TextOverride 有两种可能数据内容tt 或Empty.
以下程序可以解决,Debug.print 每个尺寸的数据.
Sub ls()
Dim Ent As AcadEntity, objDim As AcadDimension
Dim tempBlock As AcadBlock
With ThisDrawing
'Debug.Print .Blocks.Count, "ModelSpace:" & .ModelSpace.Count
For Each Ent In .ModelSpace
If Ent.ObjectName Like "AcDb*Dimension" Then
Set objDim = Ent.Copy()
blkCount = .Blocks.Count
Set tempBlock = .Blocks.Item(blkCount - 1)
For jj = 0 To tempBlock.Count - 1
Select Case tempBlock.Item(jj).ObjectName
Case "AcDbMText"
Debug.Print tempBlock(jj).TextString
'Ent.TextOverride = tempBlock(jj).TextString
Case "AcDbPoint"
End Select
Next jj
objDim.Delete
End If
'Debug.Print .Blocks.Count, "ModelSpace" & .ModelSpace.Count
Next Ent
End With
End Sub
''
Sub ls()
Dim Ent As AcadEntity, objDim As AcadDimension
Dim tempBlock As AcadBlock
With ThisDrawing
'Debug.Print .Blocks.Count, "ModelSpace:" & .ModelSpace.Count
For Each Ent In .ModelSpace
If Ent.ObjectName Like "AcDb*Dimension" Then
Set objDim = Ent.Copy()
blkCount = .Blocks.Count - 1
Debug.Print "BLKCOUNT", blkCount
If blkCount + 1 And Left(.Blocks(blkCount).Name, 2) = "*D" Then
Set tempBlock = .Blocks.Item(blkCount)
Debug.Print objDim.Handle, tempBlock.Handle
For jj = 0 To tempBlock.Count - 1
Select Case tempBlock.Item(jj).ObjectName
Case "AcDbMText"
Debug.Print tempBlock(jj).TextString
'Ent.TextOverride = tempBlock(jj).TextString
Case "AcDbPoint"
End Select
Next jj
objDim.Delete
End If
End If
'Debug.Print .Blocks.Count, "ModelSpace" & .ModelSpace.Count
Next Ent
End With
End Sub
页:
[1]