Insert picture caption and group

[Paul_Hossler]

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

18877

[Paul_Hossler]

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

[macropod]

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

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:

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

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.

[Paul_Hossler]

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


http://www.msofficeforums.com/word-vba/19707-macro-add-captions-pictures-inside-word-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





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

[macropod]

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.

[Paul_Hossler]

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




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

[Paul_Hossler]

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


18888





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

[Paul_Hossler]

@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

18894

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

[Roderick]

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

[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:

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?

[Paul_Hossler]

I'd have thought that a DOTM is a DOTM

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

[Roderick]

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!