请问为什么我直接标注就好使，而把标注建在块里就不好使了呢？

freshair

请问为什么我打问号处，如直接标注就好使，而把标注建在块里就不好使了呢？

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

efan2000

可能是因为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

mccad

这确实是AutoCAD对象模型的BUG。
晕，对象模型的BUG也太多了。

freshair

多谢指教！

freshair

我按先拷贝再删除的方法好使了。