请问为什么我直接标注就好使，而把标注建在块里就不好使了呢？
请问为什么我打问号处，如直接标注就好使，而把标注建在块里就不好使了呢？Option Explicit
Public Sub InsertBlockS()
Dim insertPnt(0 To 2) As Double
'指定模型空间的插入点
'insertPnt(0) = 200: insertPnt(1) = 100: insertPnt(2) = 0
insertPnt(0) = 0: insertPnt(1) = 0: insertPnt(2) = 0
InsertB insertPnt(), 1
ZoomAll
End Sub
Public Sub InsertB(insertPnt() As Double, scale1 As Double)
' -------------------------------------------------------------------
' 设定序号层
Dim layerObj As AcadLayer
Dim curlayerObj As AcadLayer
' 添加一个序号层
Set layerObj = ThisDrawing.Layers.Add("numlayer")
layerObj.Color = acGreen ' 设序号层为绿色
Set curlayerObj = ThisDrawing.ActiveLayer ' 保存当前活动层
ThisDrawing.ActiveLayer = layerObj ' 设序号层为当前层
If layerObj.Lock Then
layerObj.Lock = False ' 保证序号层不要加锁
End If
' -------------------------------------------------------------------
On Error Resume Next
Dim I, J As Integer
Dim BlockObj As AcadBlock
Dim blkRefObj As AcadBlockReference
Dim insPnt(0 To 2) As Double
'准备创建一个图块 设定图块对象的原点坐标
insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
Set BlockObj = ThisDrawing.Blocks.Add(insPnt, "Block")
'---------------------------------------------
'本段代码将在块对象中创建图元对象
Dim cirObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
Dim lineObj As AcadLine
Dim sPnt(0 To 2) As Double, ePnt(0 To 2) As Double
Dim location(0 To 2) As Double
Dim StrA As String
'创建直线
sPnt(0) = -400: sPnt(1) = 200: sPnt(2) = 0
ePnt(0) = 400: ePnt(1) = 200: ePnt(2) = 0
Set lineObj = BlockObj.AddLine(sPnt, ePnt)
sPnt(0) = -400: sPnt(1) = 0
ePnt(0) = -400: ePnt(1) = 200
Set lineObj = BlockObj.AddLine(sPnt, ePnt)
sPnt(0) = 400: sPnt(1) = 0
ePnt(0) = 400: ePnt(1) = 200
Set lineObj = BlockObj.AddLine(sPnt, ePnt)
sPnt(0) = -400: sPnt(1) = 0: sPnt(2) = 0
ePnt(0) = 400: ePnt(1) = 0: ePnt(2) = 0
Set lineObj = BlockObj.AddLine(sPnt, ePnt)
'正上方标注
Dim dimaObj As AcadDimAligned '声明对齐尺寸对象变量
location(0) = sPnt(0): location(1) = ePnt(1) + 400: location(2) = 0#
UseDimAligned sPnt(), ePnt(), location() '好用 ????????
'Set dimaObj = BlockObj.AddDimAligned(sPnt(), ePnt(), location())'不好用 ???????
'------------------------------------------
'插入图块
Set blkRefObj = ThisDrawing.ModelSpace.InsertBlock(insertPnt, _
"Block", scale1, scale1, 1#, 0#)
blkRefObj.Update
ThisDrawing.Regen True
ZoomAll
End Sub
Public Sub UseDimAligned(point1() As Double, point2() As Double, location() As Double)
Dim dimObj As AcadDimAligned '声明对齐尺寸对象变量
'在模型空间中创建对齐尺寸标注对象
Set dimObj = ThisDrawing.ModelSpace.AddDimAligned(point1, point2, location)
dimObj.Color = 4
dimObj.ArrowheadSize = 8
dimObj.TextHeight = 80
dimObj.DecimalSeparator = "."
dimObj.ToleranceHeightScale = 0.9
dimObj.TolerancePrecision = acDimPrecisionFour
dimObj.ToleranceUpperLimit = 0.002
dimObj.ToleranceLowerLimit = 0.001
dimObj.Fit = acArrowsOnly
dimObj.Update
End Sub 可能是因为ACAD只有在模型空间中才更新标注的缘故吧。
检查了一下，在块Block中的标注的文字尺寸值是80。但是在标注块*D???（标注也是一个块，是以D字母开头的匿名块）的多行文字高度却还是2.5，说明实际并没有更新。
一种方法是：在模型空间创建完标注之后，使用CopyObjects方法将其拷贝到块中，然后删除标注。如：
Dim EntObj(0) As AcadEntity
Set EntObj(0) = dimObj
ThisDrawing.CopyObjects EntObj, ThisDrawing.Blocks("Block")
dimObj.Delete
另一种方法是：在块集合中找到标注块，然后查找其中的多行文字（也就是显示的标注尺寸值的对象），更改其高度。这种方法的缺点是文字的设置比较困难。如：
Sub Test()
'刚创建的标注，那么它在块集合中的位置是最后一个。
Dim BlockObj As AcadBlock
Set BlockObj = ThisDrawing.Blocks(ThisDrawing.Blocks.Count - 1)
Dim EntObj As AcadEntity
For Each EntObj In BlockObj
If EntObj.ObjectName = "AcDbMText" Then
'Debug.Print EntObj.Height 显示2.5
EntObj.Height = 80
EntObj.Update
End If
Next
End Sub 这确实是AutoCAD对象模型的BUG。
晕，对象模型的BUG也太多了。 多谢指教！ 我按先拷贝再删除的方法好使了。
页:
[1]