'连续标注
Sub LXBZ()
    Dim P()  As Variant '标注点集
    Dim temp As Variant '标注位置
    Dim i As Integer, j As Integer, L As Long
    Dim E() As AcadEntity '标注对象集
    
    Dim LXBZGroup As AcadGroup
    Dim NiMing As String
    NiMing = NiMingZu("LXBZ")
    Set LXBZGroup = ThisDrawing.Groups.Add(NiMing)
    On Error GoTo E:
    ReDim Preserve P(1)
    ReDim Preserve E(0)
    '创建第一个标注，后面的标注均以这个标注为基准。
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(0) = ThisDrawing.Utility.GetPoint(, "指定点:>")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(1) = ThisDrawing.Utility.GetPoint(P(0), "下一点:>")
    Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), CenterPoint(P(0), P(1)))
    '标注尺寸线位置:
    ThisDrawing.Utility.InitializeUserInput 1, ""
    temp = ThisDrawing.Utility.GetPoint(CenterPoint(P(0), P(1)), "标注尺寸线位置:>")
    '删除一个尺寸标注，按照新的位置重新标注。
    E(0).Delete
    Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(0), P(1), temp)
    i = 1
N:
    '标注下一点
    i = i + 1
    ReDim Preserve P(i)
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(i) = ThisDrawing.Utility.GetPoint(P(i - 1), "下一点")
    '为了使标注在一条直线上，所以要求新的点到直线的垂足点坐标。
    P(i) = ChuiZuP2L(P(i - 2), P(i - 1), P(i))
    '如果这个点在前面的所有点中间，就要分割他相邻两点之间的一个标注。这里的处理方法删除了前面标注重新再标注。
    For L = 0 To UBound(E)
        E(L).Delete
    Next
    '重新定义数值
    ReDim E(i - 1)
    '对点坐标进行排序
    DianPaiXu1 P
    '绘制新的连续标注
    For j = 0 To i - 1
        Set E(j) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), temp)
    Next
    GoTo N:
E:
    LXBZGroup.AppendItems E
    Prompt Err.Description
End Sub

'增补标注
Sub ZBBZ()
    Dim P()  As Variant '标注点集
    Dim E() As AcadEntity '标注对象集
    Dim TP As Variant
    Dim DStyle As String
    Dim DLayer As String
    Dim i As Integer, j As Integer
    
    ReDim Preserve P(1)
    ReDim Preserve E(0)
    
    Dim LXBZGroup As AcadGroup
    Dim NiMing As String
    NiMing = NiMingZu("LXBZ")
    Set LXBZGroup = ThisDrawing.Groups.Add(NiMing)

    Dim D1 As AcadDimAligned
    Dim D2 As AcadDimRotated
    Dim temp As AcadEntity
    Dim PickedPoint As Variant
    On Error GoTo E:
N:
    '先选择一个标注对象
    ThisDrawing.Utility.GetEntity temp, PickedPoint, "请选择一个标注对像"
    If temp.ObjectName = "AcDbRotatedDimension" Then
        GoTo N:
    ElseIf temp.ObjectName = "AcDbAlignedDimension" Then
       '获得该对齐对象的特性，
       Set D1 = temp
       P(0) = D1.ExtLine1Point
       P(1) = D1.ExtLine2Point
       TP = D1.TextPosition
       DStyle = D1.StyleName
       DLayer = D1.Layer
       D1.Delete
       Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(0), P(1), TP)
       'Set E(0) = temp
    Else
        GoTo N:
    End If
    i = 1
M:
    '标注下一点
    i = i + 1
    ReDim Preserve P(i)
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(i) = ThisDrawing.Utility.GetPoint(P(i - 1), "下一点")
    '为了使标注在一条直线上，所以要求新的点到直线的垂足点坐标。
    P(i) = ChuiZuP2L(P(i - 2), P(i - 1), P(i))
    '如果这个点在前面的所有点中间，就要分割他相邻两点之间的一个标注。这里的处理方法删除了前面标注重新再标注。
    For j = 0 To UBound(E)
        E(j).Delete
    Next
    '重新定义数值
    ReDim E(i - 1)
    '对点坐标进行排序
    DianPaiXu1 P
    '绘制新的连续标注
    For j = 0 To i - 1
        Set E(j) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), TP)
        E(j).StyleName = DStyle
        E(j).Layer = DLayer
    Next
    GoTo M:
E:
    If UBound(E) <> 0 Then LXBZGroup.AppendItems E
    Prompt Err.Description
End Sub