Insert picture caption and group

I'd have thought this would be a simple macro to record and generalize, but no luck; the Word object model is fighting me all the way


All I'm trying to do is select a picture (first para in attachment), and use InputBox to enter the caption


1. If Inline, make it Square. If Square already, continue. If not 'caption-able' then exit

2. Insert picture caption with text from InputBox (it defaults to caption style so that's good)

3. Group the picture and the caption

I want the end result to look like para2

This is getting into some Word areas that are new territory for me, so I'm looking for some help. Thanks

Attachment 18877

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

Code:

---

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

---

IMHO you'd do better to put the images & captions into floating tables, so you can ensure they always move together, using something like:

Code:

---

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
With ActiveDocument
  For i = 1 To .InlineShapes.Count
    If .InlineShapes(i).Range.Information(wdWithInTable) = False Then
      PicWdth = .InlineShapes(i).Width
      Set Rng = .InlineShapes(i).Range
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        PicWdth = .InlineShapes(1).Width
        PicHght = .InlineShapes(1).Height
        .InlineShapes(1).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
  Next
  While .Shapes.Count > 0
    BShp = True
    With .Shapes(1)
      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)
  Wend
End With
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 = True
  .Columns.Width = PicWdth
  .TopPadding = 0
  .BottomPadding = 0
  .LeftPadding = 0
  .RightPadding = 0
  .Spacing = 0
  .Rows(1).HeightRule = wdRowHeightExactly
  .Rows(1).Height = PicHght
  With .Rows
    .LeftIndent = 0
    If BShp = True Then
      .WrapAroundText = True
      .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:="", _
      Position:=wdCaptionPositionBelow, ExcludeLabel:=0
    .Paragraphs.First.Range.Characters.Last.Text = vbNullString
    .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    .Borders(wdBorderRight).LineStyle = wdLineStyleNone
    .Borders(wdBorderTop).LineStyle = wdLineStyleNone
  End With
End With
End Sub

---

The above code embeds all Shapes & InlineShapes in a document in tables as InlineShapes with a row for Captions. Whatever positioning applied to the original Shape object will apply to the table also. This arrangement has the advantage that captions in floating tables will show up in a Table of Figures, whereas captions in textboxes don't.

To have the caption row appear above the image, instead of below, change the Rows(1) references to Rows(2), change the Cell(1, 1) references to Cell(2, 1) and change the change the Cell(2, 1) references to Cell(1, 1).

To work with just the selected image (or multiple images in a selected range), change:
With ActiveDocument
to:
With Selection
and change:

Code:

---

  While .Shapes.Count > 0
    With .Shapes(1)

---

to:

Code:

---

  While .ShapeRange.Count > 0
    With .ShapeRange(1)

---

I haven't included code for the user to type in the caption while the code is running. That can be done post-reformatting and would be too error-prone (IMHO) if the code is processing multiple images.

Actually, I had Googled and found your other post from 2014


http://www.msofficeforums.com/word-v...-document.html



It has some advantages, but I started out thinking my need was much simpler since I wanted to do the captions one at a time.


The table approach might be a better idea, so I'll have to see about blending some of what I have for one at a time with your table code

Quote:

---

This arrangement has the advantage that captions in floating tables will show up in a Table of Figures, whereas captions in textboxes don't.

---

In 2016, it seems that selecting a Figure and then an Insert Caption, while it's a text box, will still show in a TOF

Quote:

---

Originally Posted by Paul_Hossler

I started out thinking my need was much simpler since I wanted to do the captions one at a time.

---

As indicated in my reply, the code is easily modified to work with one or more selected images only.

Quote:

---

Originally Posted by macropod

As indicated in my reply, the code is easily modified to work with one or more selected images only.

---

Quote:

---

The table approach might be a better idea, so I'll have to see about blending some of what I have for one at a time with your table code

---

Yes, I saw that. I'll investigate

Well, there's some progress.

I used my 'selected shape' logic and your 'insert a table' and it works pretty good

Couple of things I'm stuck on so I'd appreciate a (big) nudge

1. Figure 1 is inline. How do I make the entire table square so it sits inside the paragraph like my manual PHB table?

2. Figures 1 and 2 have a trailing paragraph in cell 2,1. How can I get rid of it?

Thanks


Attachment 18888

Code:

---

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
            .LeftIndent = 0
            If BShp = True Then
                .WrapAroundText = True
                .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
            .Paragraphs.First.Range.Characters.Last.Text = vbNullString
        End With
    End With
End Sub

---

@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

Attachment 18894

Thanks for your help

Code:

---

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

---

I'd just like to thank you all for this thread.

I was looking for something which could answer a similar query and this answered it.

Thanks again!

Roderick

Continuing my earlier post above, I've got a challenge when using the code in one of my templates.

If I put Paul's final coding into a test .dotm it works perfectly every time. Thanks!

I then transfer the code to one of my .dotm templates expecting it to run the same as the test template but it doesn't. Well, it works OK if the picture is an inline shape but when it is a shape it fails.

The code is below:

Code:

---

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

---

Everything seems to work up to the point where it meets '.Range.Cut' when instead of cutting it to the clipboard it seems to just delete it as it doesn't seem to have arrived at the clipboard, therefore an error comes up when it's going to be pasted into the receiving table cell.

I've changed the code in all ways but still the picture does not get placed in the clipboard. I cannot understand it as it worked well in my test template.

Any thoughts or suggestions, please?

I'd have thought that a DOTM is a DOTM

Can you attachment your DOTM - delete anything not needed to show the issue

Thanks for your post, Paul.

As it is a client's template, I went to them for permission to post online but, regrettably, they said 'No.' Oh well...

I agree with you: a .dotm is a.dotm, so what's the difference here? As it works in a clean and simple template with no other procedures in it, I can only come to the idea that there is something in my template which is causing it to go silly when it's not an inline shape.

As I mentioned earlier, this part, with inline shapes, works perfectly.

I've got a procedure already which I have been using, but I much prefer this table structure. I'm going to keep playing with it and see if I can find a solution. I'll export it to another template and see what happens.

By the way, I'm using Windows 7 and Word 2013.

I'n the meantime, thanks again for the coding above!