@macropod --

I think I've got it

I can select an Inline or Square shape and run you table macro on it and get some nice (to me anyway) results

The captions seem to come out OK and the TOF works this way!!

I still have a little cleanup and some commenting to do (before I forget) so that'll be the easy parts

Capture.JPG

Thanks for your help


Option Explicit
Dim sCaption As String

Sub AddImageCaptionTables()
    Dim iShp As InlineShape, Rng As Range, Tbl As Table
    Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
    Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
    
    
    '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
        Set iShp = Selection.InlineShapes(1)
            
        If iShp.Range.Information(wdWithInTable) = False Then
            PicWdth = iShp.Width
            Set Rng = iShp.Range
            With Rng
                If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
                PicWdth = iShp.Width
                PicHght = iShp.Height
                iShp.Range.Cut
            End With
            BShp = False
            VRel = 0
            HRel = 0
            VPos = 0
            HPos = 0
            
            Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
        End If
        
    ElseIf Selection.Type = wdSelectionShape Then
        BShp = True
        With Selection.ShapeRange
            PicWdth = .Width
            PicHght = .Height
            VRel = .RelativeVerticalPosition
            HRel = .RelativeHorizontalPosition
            VPos = .Top
            HPos = .Left
            Set iShp = .ConvertToInlineShape
        End With
        
        With iShp
            Set Rng = .Range
            .Range.Cut
        End With
        
        Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
    
    Else
        Call MsgBox("Sorry, you have to select a Shape (or Picture) first", vbCritical + vbOKOnly, "Enter Caption")
    End If
    
End Sub
 
Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
    VRel As Long, HRel As Long, VPos As Single, HPos As Single)
    Dim Tbl As Table
     'Create & format the table
    Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1)
    With Tbl
        .Borders.Enable = False
        .Columns.Width = PicWdth
        .TopPadding = 0
        .BottomPadding = 0
        .LeftPadding = 0
        .RightPadding = 0
        .Spacing = 0
        .Rows(1).HeightRule = wdRowHeightExactly
        .Rows(1).Height = PicHght
        With .Rows
            .WrapAroundText = True      '   PH
            .LeftIndent = 0
            If BShp = True Then
                .HorizontalPosition = HPos
                .RelativeHorizontalPosition = HRel
                .VerticalPosition = VPos
                .RelativeVerticalPosition = VRel
                .AllowOverlap = False
            End If
        End With
        With .Cell(1, 1).Range
            With .ParagraphFormat
                .SpaceBefore = 0
                .SpaceAfter = 0
                .LeftIndent = 0
                .RightIndent = 0
                .FirstLineIndent = 0
                .KeepWithNext = True
            End With
            .Paste
        End With
        With .Cell(2, 1).Range
            .Style = "Caption"
            .End = .End - 1
            .InsertAfter vbCr
            .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:=" " & sCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=0    '   PH
            .Paragraphs.First.Range.Characters.Last.Text = vbNullString
            .Paragraphs.Last.Range.Characters.Last.Text = vbNullString      '   PH
        End With
    End With
End Sub