#1
|
|||
|
|||
Macro to add captions to pictures inside word document
Hi,
I am very new to VB and Macros. I have around 100 images in my document and i need to assign format style "Captions" to all my images and insert Figure Captions below images as "Figure 1: <<Insert Titele Here>>". I recorded macro and my macro look like below and unable to loop this for entire document. Sub Macro1() ' ' Macro1 Macro ' ' Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="1" Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^g" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Selection.Style = ActiveDocument.Styles("Caption") Selection.InsertCaption Label:="Figure", TitleAutoText:="InsertCaption1", _ Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0 End Sub |
#2
|
||||
|
||||
There are two kinds of image formats one can encounter with a Word document: in-line and floating. With the in-line format, it's quite easy to insert a caption after the image and know where it will be in relation to that image. With floating shapes, however, the only way of ensuring the captions align with the images is to insert textboxes that can be positioned near the images.
In either case, the problem then becomes one of ensuring the captions and images stay together on the same page. The best way of doing this is to insert both the image and its caption into a Word table. For floating shapes, that means changing their format to in-line, but that's OK since the table can be made to float over the text in much the same way. Compared to what's involved in the above, finding the in-line shapes and floating shapes is quite easy; instead of using Find, you loop through the InlineShape and Shape collections, respectively. For example, the following macro embeds all Shapes & InlineShapes in a document in tables with a row for Captions. 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, sngScl As Single, iShp As InlineShape '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 ' Resize the inserted InlineShape Set iShp = .InlineShapes(1) With iShp .Width = PicWdth .Height = PicHght End With 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 .Paragraphs.First.Range.Characters.Last.Text = vbNullString End With End With End Sub PS: When posting code, please use the code tags. They're on the 'Go Advanced' tab.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Regarding the topic Macro to add captions to pictures inside word document
Hi Paul
I wonder if you could help me with creating a caption in another way. We have this tool that creates a RTF document which I have converted to *.doc by running a macro and using the ActiveDocument.SaveAs2 function. In the document I have some fields codes with the tag "xe" and description of the diagram. Is it possible to use a similar macro in this topic to replace the "xe" tag and use the caption with the descriptiont. It is OK if the picture and caption is not on the same page, but it would be "nice to have". The "xe" tag will always follow the picture. I ran you code AddImageCaptionTables just to see how it looks but then I do not have any text to the caption. /Regards Benble |
#4
|
||||
|
||||
Try running the following macro after the AddImageCaptionTables macro (you can call this one from that one):
Code:
Sub AddCaptionText() Dim Tbl As Table, RngCell As Range, RngRef As Range, StrTxt As String For Each Tbl In ActiveDocument.Tables Set RngCell = Tbl.Range.Cells(Tbl.Range.Cells.Count).Range With RngCell .End = .End - 1 .Collapse wdCollapseEnd If .Style = "Caption" Then Set RngRef = .Paragraphs.Last.Next.Next.Range With RngRef .End = .End - 1 If .Fields.Count = 1 Then If .Fields(1).Type = wdFieldIndexEntry Then StrTxt = Trim(Replace(Replace(.Fields(1).Code.Text, "XE ", _ vbNullString, , , vbTextCompare), Chr(34), "")) With RngCell .Text = ": " & StrTxt .Collapse wdCollapseEnd .FormattedText = RngRef.FormattedText End With .Paragraphs.First.Range.Delete End If End If End With End If End With Next End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Hi Paul!
Many thanks for the code and a prompt reply, works like a charm. I wonder if it is simple to change this AddCaptionText or the AddImageCaptionTables function to have the text above the image (in row 1 instead of having the caption the after the image). /Kind regards Benble |
#6
|
|||
|
|||
Regarding the topic Macro to add captions to pictures inside word document
Hi Paul!
What is the code to expand the table so the text in the table is not written in several lines (unless it is so large the it does not fit on one row on the whole page). See attached pic's . The first one show the result now after the functions AddImageCaptionTables and AddCaptionText and the second is the look and feel I would like to have. pic1.jpg pic2.jpg (You should now that I think this really good site to get help from. It helps me a lot!) Kind Regards Benble |
#7
|
||||
|
||||
Quote:
Quote:
PicWdth = .InlineShapes(i).Width and the code line that applies it is: .Columns.Width = PicWdth Without the second of the above lines, the table widths will fill the margins. A compromise might be to set a minimum width for PicWdth, via either of: If PicWdth < CentimetersToPoints(8.9) Then PicWdth = CentimetersToPoints(8.9) or: If PicWdth < InchesToPoints(3.5) Then PicWdth = InchesToPoints(3.5) immediately after the PicWdth = .InlineShapes(i).Width lines. You could, of course, change the units indicated to something else.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
|||
|
|||
Hi Paul
Thanks for the help. Then the text will be below the image. I have used you suggestion to make a compromise by set a minimum width for PicWdth. /Regards Benble |
#9
|
|||
|
|||
Hi Paul,
I'm having a similar problem with adding captions to images in Word. Your first macro works well for the first time, however, if I tried to run it again when I added some new images to the document, it would just do nothing at all. Can you check on this? Last edited by macropod; 03-31-2016 at 08:17 PM. Reason: Deleted unnecessary quote of entire post replied to |
#10
|
||||
|
||||
The macro is not intended to be used every time you insert a new image; it's a one-off conversion process. For code you could use when inserting new pics, see: https://www.msofficeforums.com/word/...html#post78488
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
|||
|
|||
Quote:
|
#12
|
||||
|
||||
The problem you're having with pictures being skipped and the code error-ing out is most likely due to there being no content between the pictures (i.e. they're next to each other or there's only a single paragraph break between them). The code really wasn't designed for that. You need to have at least an empty paragraph between the pics. I've fixed the code to address the loss of the 'F' at the beginning of 'Figure'.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#13
|
|||
|
|||
Apologies for resurrecting an old thread, but I have a similar issue and I haven't been able to find a work around yet.
I have a word doc that includes hundreds of pictures (jpg) inserted in cells of a table, with two columns per row. In each cell there is either one single picture or some text, never both. I have been asked to go through this document and add a simple figure reference to each picture. I'm looking for help with a macro that can read the entire thing and add 'Fig. 1' etc, under each picture in 9pt Arial. I'm a complete novice with macros and have only used those that other people have written; I have no idea if this is even possible, but help would be appreciated. Thank you . |
#14
|
||||
|
||||
Maybe something like
Code:
Sub Macro1() Dim oCell As Cell Dim oShape As InlineShape With ActiveDocument.Styles("Caption").Font .Name = "Arial" .Size = 9 .Color = wdColorAutomatic End With For Each oCell In Selection.Tables(1).Range.Cells If oCell.Range.InlineShapes.Count = 1 Then Set oShape = oCell.Range.InlineShapes(1) oShape.Range.InsertCaption _ Label:="Figure", _ TitleAutoText:="InsertCaption1", _ Title:="", _ Position:=wdCaptionPositionBelow, _ ExcludeLabel:=0 End If DoEvents Next oCell lbl_Exit: Set oShape = Nothing Set oCell = Nothing Exit Sub End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#15
|
|||
|
|||
Thank you! That's worked a treat!
|
Tags |
automatic figure caption |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
VBA to insert captions without appending to existing captions | Marrick13 | Word VBA | 17 | 03-21-2023 07:51 PM |
Help formatting Pictures inside a Text Box in Word 2013 | jstumbo87 | Word | 2 | 01-29-2014 12:07 PM |
Macro to read word document | harishankar.selvaraju | Excel Programming | 1 | 06-14-2012 03:48 AM |
Where we can find a Word document (docx file) that contains professional work inside? | Jamal NUMAN | Word | 0 | 06-26-2011 09:57 AM |
Captions and Figures Inside a Frame...RIDICULOUS MS hasn't developed a solution!!! | stlsmiln | Word | 2 | 02-23-2010 02:15 AM |