Sub AddPicDatesAbove()
Application.ScreenUpdating = False
Dim iShp As Long, dStartDate As Date, oRng As Range, strOrd As String
dStartDate = CDate("01/01/2018") - 1
With ActiveDocument
  For iShp = 1 To .InlineShapes.Count
    dStartDate = dStartDate + 1
    strOrd = DateOrdinal(Format((dStartDate), "d"))
    Set oRng = .InlineShapes(iShp).Range
    With oRng
      .ParagraphFormat.Alignment = wdAlignParagraphCenter
      .Collapse wdCollapseStart
      .Text = vbCr & Format((dStartDate), "mmmm d") & strOrd & Format((dStartDate), " yyyy") & Chr(11)
      .Start = .Start + 1
      .Font.Size = 24
      .Start = .Start + InStr(.Text, strOrd) - 1
      .End = .Start + 2
      .Font.Superscript = True
    End With
  Next iShp
End With
Set oRng = Nothing
Application.ScreenUpdating = True
End Sub

Function DateOrdinal(Val As Long) As String
Dim strOrd As String
If (Val Mod 100) < 11 Or (Val Mod 100) > 13 Then strOrd = Choose(Val Mod 10, "st", "nd", "rd") & ""
DateOrdinal = IIf(strOrd = "", "th", strOrd)
End Function