VBA to insert captions without appending to existing captions

macropod · #16 02-19-2012, 01:17 AM

Hi Marrick,

Try:

Code:

Sub ApplyCaptions()
Application.ScreenUpdating = True
Dim oCap As CaptionLabel, bCap As Boolean, iShp As InlineShape, oTbl As Table, TmpRng As Range
With ActiveDocument
  For Each iShp In .InlineShapes
    Set TmpRng = iShp.Range.Paragraphs.First.Range
    With TmpRng
      If .Style = "Caption" Then bCap = ChkCaption(TmpRng)
      If .Paragraphs.Last.Next.Range.Style = "Caption" And bCap = False Then
        bCap = ChkCaption(TmpRng)
      End If
      If bCap = False Then
        iShp.Range.InsertCaption Label:="Figure", TitleAutoText:="", _
          Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
      End If
    End With
  Next
  For Each oTbl In .Tables
    Set TmpRng = oTbl.Range.Paragraphs.Last.Range
    With TmpRng
      If .Style = "Caption" Then bCap = ChkCaption(TmpRng)
      If .Paragraphs.Last.Next.Range.Style = "Caption" And bCap = False Then
        bCap = ChkCaption(TmpRng)
      End If
      If bCap = False Then
        oTbl.Range.InsertCaption Label:="Table", TitleAutoText:="", _
          Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
      End If
    End With
  Next
End With
Set TmpRng = Nothing
Application.ScreenUpdating = False
End Sub
 
Function ChkCaption(TmpRng As Range) As Boolean
Dim oCap As CaptionLabel
ChkCaption = False
For Each oCap In CaptionLabels
  If InStr(TmpRng.Text, CaptionLabels(oCap)) > 0 Then
    ChkCaption = True
    Exit For
  End If
Next
End Function

Depending on the # of tables & inlineshapes, this might take a while.

Marrick13 · #17 02-19-2012, 06:06 AM

Hits the spot, Paul. Thanks so much!

FrostKo · #18 03-21-2023, 07:51 PM

This helped tremendously! I ended taking what I needed but it was generating an error if there wasn't two empty paragraphs after the last image. I wanted to share my code. This allows for the error to occur but adds the caption anyway without any empty paragraphs after the last image.

Code:

Sub Captions()
On Error GoTo Error
Application.ScreenUpdating = True
Dim RngStry As Range, iShp As InlineShape, TmpRng As Range
For Each RngStry In ActiveDocument.StoryRanges
  For Each iShp In RngStry.InlineShapes
    Set TmpRng = iShp.Range.Paragraphs.First.Range
    With TmpRng
      If .Style <> "Caption" Then
        If .Paragraphs.Last.Next.Style <> "Caption" Then
        Exit Sub
Error:
          iShp.Range.InsertCaption Label:="Photo", TitleAutoText:="", _
           Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
        End If
      End If
    End With
  Next
Next
Set TmpRng = Nothing
Application.ScreenUpdating = False
Resume Next
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Move existing table captions	bcarlier	Word Tables	17	05-10-2014 02:36 PM
Captions/Styles	NWoffice	Word	5	10-06-2011 10:26 AM
creating tables for row of figures and captions	gib65	Word	2	08-12-2011 01:25 PM
Captions (tables and figures)	mcjohn	Word	1	02-11-2010 10:36 PM
Captions	dwilliams	Word	0	10-07-2009 08:30 AM