Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Closed Thread
 
Thread Tools Display Modes
  #1  
Old 10-10-2022, 02:38 PM
macropod's Avatar
macropod macropod is offline Work Around Word’s Limitations with Image Captioning Windows 10 Work Around Word’s Limitations with Image Captioning Office 2016
Administrator
Work Around Word’s Limitations with Image Captioning
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default Work Around Word’s Limitations with Image Captioning


When images are positioned with text wrapping 'Square', Word inserts their captions into text boxes. In such situations, the caption ordering for multiple shapes anchored to a single paragraph is hard to control because it’s based on the order of the anchors in the document stream (which you can’t see). Captions in textboxes create other problems of their own if you create a Table of Figures (TOF); in that case, Word inserts a fully-qualified path into the TOF, which creates problems when the file is saved as PDF (the TOF links back to the original document).

The following macro resolves these issues by inserting the images into the cells of floating tables, as inlineshapes, with the captions in the tables also. As coded, the macro processes all floating & inline images, but it could be stripped down to work with just the floating images or even just a selected image. Either way, the disconnect between the images and their captions will be resolved. Whatever positioning and text wrapping applied to the original image will apply to the table also.

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).

Note that, due to the extra space taken up by the caption row, all except for the first of the document's pictures are liable to shift position.

Once the macro has run, it will be a simple matter to move any existing captions into the empty cells provided and delete whatever paragraphs/textboxes those captions formerly occupied.
Code:
Sub AddImageCaptionTables()
Application.ScreenUpdating = False
'Sourced from: https://www.msofficeforums.com/drawing-and-graphics/49784-work-around-word-limitations-image-captioning.html
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 
      With .InlineShapes(i)
        .LockAspectRatio = True
        PicWdth = .Width
        PicHght = .Height
        Set Rng = .Range
      End With
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .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) 
      .LockAspectRatio = True
      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, sngScl As Single, iShp As InlineShape
'Constrain maximum image size
If PicWdth > CentimetersToPoints(7.5) Then
  sngScl = PicWdth / CentimetersToPoints(7.5)
  PicWdth = PicWdth / sngScl
  PicHght = PicHght / sngScl
End If
If PicHght > CentimetersToPoints(5) Then
  sngScl = PicHght / CentimetersToPoints(5)
  PicWdth = PicWdth / sngScl
  PicHght = PicHght / sngScl
End If
'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
    'Resize the inserted InlineShape
    Set iShp = .InlineShapes(1)
    With iShp
      .Width = PicWdth
      .Height = PicHght
    End With
  End With
  'Insert the caption
  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
Application.ScreenUpdating = True
End Sub
To work with just the selected image (or multiple images in a selected range), change:
Code:
With ActiveDocument
to:
Code:
With Selection
and change:
Code:
  While .Shapes.Count > 0
    With .Shapes(1)
to:
Code:
  While .ShapeRange.Count > 0
    With .ShapeRange(1)
Note 1: As coded, the 'MakeImageTable' macro limits the inserted InlineShape dimesnsions to 7.5*5.0cm. That code can, of course, be edited/omitted. If it is to be omitted, so too can the corresponding code that re-sizes the inserted InlineShape to fit. The code concerned is found between 'Constrain maximum image size' and 'Create & format the table', and between 'Resize the inserted InlineShape' and 'Insert the caption', respectively.

Note 2: As coded, the 'MakeImageTable' macro inserts the word 'Figure' as the caption label for each caption. That label can be changed to something else, or that part of the code can be omitted entirely.

For PC macro installation & usage instructions, see: Installing Macros
For Mac macro installation & usage instructions, see: Word:mac - Install a Macro
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Closed Thread

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
re: How does OneNote's copy from image work? Tom Layman OneNote 0 10-17-2017 06:09 AM
Trying to work on on image wabash12 PowerPoint 3 06-25-2013 07:52 AM
Captioning with different Headings judicial85 Word 3 03-05-2012 05:06 PM
Picture Captioning judicial85 Word 0 02-06-2012 06:18 AM
Help Relieve Captioning Torture! trhindc Word 0 05-12-2010 10:25 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 11:06 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft