Make 1 selection or multiple then run. I assigned the letter d as a shortcut. select a shape and hit d.
Sub DimensionAll()
Dim srSelection As ShapeRange
Dim x As Double, y As Double, w As Double, h As Double
Dim sPt1 As SnapPoint, sPt2 As SnapPoint
Dim s As Shape
Optimization = True
ActiveDocument.BeginCommandGroup "Quick Dimensions"
EventsEnabled = False
ActiveDocument.SaveSettings
ActiveDocument.PreserveSelection = False
On Error GoTo ErrHandler
Set srSelection = ActiveSelectionRange
For Each s In srSelection
s.GetBoundingBox x, y, w, h
Set sPt1 = CreateSnapPoint(x, y + h)
Set sPt2 = CreateSnapPoint(x + w, y + h)
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, sPt1, sPt2, True, , , cdrDimensionStyleFractional, Units:=cdrDimensionUnitIN)
s.Dimension.TextShape.SetPosition x + w / 2, y + h + 1
s.Dimension.TextShape.Text.Story.Size = 54
Set sPt1 = CreateSnapPoint(x, y)
Set sPt2 = CreateSnapPoint(x, y + h)
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, sPt1, sPt2, True, , , cdrDimensionStyleFractional, Units:=cdrDimensionUnitIN)
s.Dimension.TextShape.SetPosition x - 1, y + sx / 2
s.Dimension.TextShape.Text.Story.Size = 54
Next s
ExitSub:
ActiveDocument.PreserveSelection = True
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
ActiveDocument.ClearSelection
ActiveWindow.Refresh
Application.Refresh
ActiveDocument.EndCommandGroup
Exit Sub
ErrHandler:
MsgBox "Error occured: " & Err.Description
Resume ExitSub
End Sub