Got something that works finally

Not as robust as I would like but it seems to have the basics. Still Open to ideas and suggestions


Option Explicit

Sub AddCaptionToSelectedShape()
    Dim sShapeName As String, sCaptionName As String
    Dim sCaption As String


    'make sure a shape-type thing is selected
    If Selection.Type <> wdSelectionShape Then
        Call MsgBox("Sorry, you have to select a Shape (or Picture) first", vbCritical + vbOKOnly, "Enter Caption")
        Exit Sub
    End If
    
    
    'get caption from user
    sCaption = InputBox("Enter the caption for the selected item", "Enter Caption")
    If Trim(sCaption) = 0 Then Exit Sub

    If Selection.Type = wdSelectionInlineShape Then
      Selection.InlineShapes(1).ConvertToShape.WrapFormat.Type = wdWrapSquare
    End If
    sShapeName = Selection.ShapeRange(1).Name


    'add picture caption
    Selection.InsertCaption Label:="Figure", TitleAutoText:="", Title:=sCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=1
    
    'get rid of field with number
    Selection.HomeKey Unit:=wdLine
    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=1
    
    'get off text and leave textbox selected
    Selection.EscapeKey
    
    sCaptionName = Selection.ShapeRange(1).Name
     
    ActiveDocument.Shapes.Range(Array(sShapeName, sCaptionName)).Select
    Selection.ShapeRange.Group
    
End Sub