Search code examples
vbams-wordformatting

check caption formats are consistent in document and update to set format

I have spent many hours in many forums trying to piece together code to check each caption in a document has the same formatting as below. I have set up styles of "Table Figure Caption" for Tables and Figures and "Photo" for Photos, but I can't get the colon after the number to default as part of the style or add a tab to the description. The numbering should be linked to the chapter, so this also needs to be checked/updated.

I am able to iterate through the captions, but am not able to figure out what code to put in that will force the formatting to be consistent without replacing the existing text in the description. Some captions will be missing the colon and the tab and others will not have the numbers updated if a Heading has been added or removed

This is the formatting I would like centered below a figure and the same above a table, but it being called Table 4-1

enter image description here

This is the formatting I would like centered below the photos

enter image description here

This is what I am using to iterated through the captions, and it is finding each caption successfully. I am able to identify the captions, I am just not sure how to structure the code to format them once I find them.

Public Sub IterateCaptions()
Dim oField As Field
Dim sCode As String
Dim bFoundOne As String

For Each oField In ActiveDocument.Fields
If oField.Type = wdFieldSequence Then
bFoundOne = False
sCode = oField.Code

'see if it's a caption sequence field
If InStr(sCode, "Table") <> 0 Then
bFoundOne = True
End If
'see if it's a caption sequence field
If InStr(sCode, "Equation") <> 0 Then
bFoundOne = True
End If
'see if it's a caption sequence field
If InStr(sCode, "Figure") <> 0 Then
bFoundOne = True
End If
'now what?
If bFoundOne Then
oField.Select
Stop
End If
End If
Next
End Sub

I had tried adding this in, but that still didn't help me with the colon and tab to description;

 With CaptionLabels("Table")
    .NumberStyle = wdCaptionNumberStyleArabic
        .IncludeChapterNumber = True
        .ChapterStyleLevel = 1
        .Separator = wdSeparatorHyphen
    .IncludeChapterNumber = True
  
  
 With CaptionLabels("Figure")
    .NumberStyle = wdCaptionNumberStyleArabic
        .IncludeChapterNumber = True
        .ChapterStyleLevel = 1
        .Separator = wdSeparatorHyphen
    .IncludeChapterNumber = True
    
    
 With CaptionLabels("Photo")
    .NumberStyle = wdCaptionNumberStyleArabic
        .IncludeChapterNumber = True
        .ChapterStyleLevel = 1
        .Separator = wdSeparatorHyphen
    .IncludeChapterNumber = False

I am sorry if I am not providing enough detail, but I have been lost down many rabbit holes on this one, so I am hoping someone can provide me with some direction.

Solution

  • Try something like this:

    Sub FindCaptions()
    Dim findRng As Range: Set findRng = ActiveDocument.Content
    With findRng
        With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Format = True
        .Style = wdStyleCaption
        .Forward = True
        .Wrap = wdFindStop
        End With
        Do While .Find.Execute
            'move start beyond caption label
            .MoveStart wdWord, 2
            If Not Left(.Text, 2) = ":" & vbTab Then
                .InsertBefore ":" & vbTab
            End If
            .Collapse wdCollapseEnd
        Loop
    End With
End Sub