Sub AddACallout()
  Dim aRange As Range, aShape As Shape, sCallout As String
  Dim bLeft As Boolean, i As Integer, sPath As String, iWidth As Integer
  
  iWidth = Selection.Sections(1).PageSetup.TextColumns(1).Width
    
  'Must be in Page Layout view for macro to show effect
  If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    ActiveWindow.ActivePane.View.Type = wdPrintView
  Else
    ActiveWindow.View.Type = wdPrintView
  End If

  If Selection.Paragraphs.Count > 1 Then
    Set aRange = Selection.Range
    aRange.Start = aRange.Paragraphs.First.Range.Start
    aRange.End = aRange.Paragraphs.Last.Range.End
  Else
    Set aRange = Selection.Paragraphs(1).Range
  End If
  sCallout = aRange.Text
  aRange.Text = ""

  Set aShape = ActiveDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=0, Top:=2, Width:=iWidth, Height:=80, Anchor:=aRange)  'msoShapeRoundedRectangle
  With aShape
    .TextFrame.TextRange = Left(sCallout, Len(sCallout) - 1)
    .TextFrame.TextRange.Style = "Normal"
    .TextFrame.MarginTop = 0
    .TextFrame.MarginLeft = 4
    .TextFrame.MarginRight = 4
    .TextFrame.MarginBottom = 4
    .TextFrame.AutoSize = True
    .WrapFormat.Type = wdWrapSquare
    .WrapFormat.Side = wdWrapBoth
    .RelativeVerticalPosition = wdRelativeVerticalPositionBottomMarginArea
    .Top = -.Height
    .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
    .Left = wdShapeLeft
    .Line.Visible = msoFalse
    .Fill.ForeColor = RGB(150, 230, 230)
  End With
End Sub