代码中有控件名称，请忽略，有备注信息，按需修改。未实现单行代码完成标注，原因未知，一些信息填写无效。
ActiveDocument.Unit = cdrMillimeter
Dim s As ShapeRange
Set s = ActiveSelectionRange
Dim pt1 As SnapPoint, pt2 As SnapPoint, pt3 As SnapPoint
Set pt1 = CreateSnapPoint(s.LeftX, s.TopY)
Set pt2 = CreateSnapPoint(s.RightX, s.TopY)
Set pt3 = CreateSnapPoint(s.RightX, s.BottomY)
Dim a As Double '字号
a = TextBox76.Value
Dim b As Double '与对象距离
b = TextBox76.Value / 2
Dim c As Double '线粗
c = TextBox77.Value
Dim d As Double '小数位
d = TextBox75.Value
'水平标注位置 '竖直标注位置
Dim x, y As Double
x = s.RightX + b
y = s.TopY + b
Dim e As Long '标注单位
If CheckBox14 = True Then
e = 0
Else
e = 3
End If
'0 英寸两点
'1 in
'2 英寸中文
'3 mm
'4 毫米中文
'5 picas
'6 点中文
'7 ciceros
'8 didots
'9 英尺单点
'10 ft
'11 yds
'12 码
'13 mi
'14 英里
'15 cm
'16 厘米
'17 m
'18 米
'19 km
'20 千米
'大于20为英寸无单位
Dim bz1, bz2 As shape
'上下水平，左右垂直
'上水平
Set bz1 = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pt1, pt2, True, TextY:=y, OutlineWidth:=c, TextSize:=a, OutlineColor:=CreateCMYKColor(0, 100, 100, 0), TextColor:=CreateCMYKColor(0, 100, 100, 0), Arrows:=ArrowHeads.Item(0))
With bz1.Style.GetProperty("dimension")
.SetProperty "units", e '标注单位
.SetProperty "precision", d '小数位数
' .SetProperty "showUnits", 0 '是否显示单位 0/1
' .SetProperty "textPlacement", 1 ' 0、上方，1、下方，2、中间
.SetProperty "dynamicText", 0 ' 是否可以编辑尺寸0/1
' .SetProperty "overhang", 500000 ' 0、上方，1、下方，2、中间
End With
Set bz2 = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pt3, pt2, True, TextX:=x, OutlineWidth:=c, TextSize:=a, OutlineColor:=CreateCMYKColor(0, 100, 100, 0), TextColor:=CreateCMYKColor(0, 100, 100, 0), Arrows:=ArrowHeads.Item(0))
With bz2.Style.GetProperty("dimension")
.SetProperty "units", e '标注单位
.SetProperty "precision", d '小数位数
' .SetProperty "showUnits", 0 '是否显示单位 0/1
' .SetProperty "textPlacement", 1 ' 0、上方，1、下方，2、中间
.SetProperty "dynamicText", 0 ' 是否可以编辑尺寸0/1
' .SetProperty "overhang", 500000 ' 0、上方，1、下方，2、中间
End With
