VBA Selection.InsertCaption and automatically adding non-breaking space between the label and number

Question

Recently I had the pleasure to review a few specification documents edited in MS Word, containing around 1000 tables and figures, each of those with a caption that did not separate caption label and number with a non-breaking space but a regular white space instead. This resulted fairly frequently in situations where for example Table was at the end of one line, and the corresponding number of the start of the next line, making the document more difficult to read.

At the end I inserted the non-breaking space into each of the captions manually. To avoid this for future specification documents, I created VBA macros that create the tables and captions, but I still need to figure out how to get the caption formatting sorted out. Currently my code is (simplified) like this:

Sub MyTableMacro()
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:= _
        4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
    ...
    ...
    End With
    Selection.InsertCaption Label:="Table", Title:=" " + ChrW(8212) + " My table title", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
End Sub

I reviewed the article here but cannot figure out what needs to modified in my code snippet above to apply the proposed method. As an extra, I'm using an English MS Word on a Windows PC, but it needs to work also on German language MACs (which messed up my first attempt with the em dash). Thanks for hints.

Answer 1

The problem for creating new captions is that when you use InsertCaption, Word inserts a space after the Label that you provide. So you need to change that space to a non-breaking space.

The following simple code relies on the knowledge that your caption will be inserted at the beginning of the Selection. I suspect generalising it so that it does not matter where the caption is interested is not trivial (I could not see how to get the Range of the new caption), so if you need something like that you might be better off by writing your own code to determine the caption position.

Sub MyTableMacro()
    Const LabelText As String = "Table"
    
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:= _
        4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
    '...
    '...
    End With
    
    
    Dim r As Range
    Set r = Selection.Range
    r.InsertCaption Label:=LabelText, Title:=" " + ChrW(8212) + " My table title", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
    ActiveDocument.Range(r.Start + Len(LabelText), r.Start + Len(LabelText)).Text = ChrW(160)
    Set r = Nothing
End Sub

I have checked that using a non-breaking space does not appear to interfere with Word's algorithm for finding Captions (which is used in the cross-reference dialog when you want to cross-reference a Caption) or the creation of a table of Table captions.

As far as I can tell, the problem with "German on Mac" is not actually to do with the em-space but is probably because the German version of Word does not have the CaptionLabel "Table" predefined (i.e. it has "Tabelle").

To fix that, you can probably just insert the caption "Table", e.g. with the following line like this

Const LabelText As String = "Table"
CaptionLabels.Add LabelText

Using "Add" does not cause an error if the Label does not exist.

I only say probably because there might be a permissions problem if the file that the labels are stored in is protected in some way.

Answer 2

I managed to fix the code, although my first solution did not work in the full example. The code below seems to work however. The reason my I added the Selection.MoveDown at the end of the macro is that I wanted the selection to be below the table just to make sure that I don't create another table inside the first table. There are probably much better ways to do this, also I want to avoid creating a table while the cursor is for example within a heading style, list style, etc. (hints welcome).

But as you indicated, the code above only works for InsertCaption with wdCaptionPositionAbove and not with wdCaptionPositionBelow. For the latter case, it puts the non-breaking space into one of the table cells.

The problem with the em dash was actually rather related to me using Chr(151) on the Windows system originally, instead of the ChrW(8212). The latter works on the Mac as well.

Thanks

Sub Data_Object_Description()
'
' Macro Data_Object_Description
' Create a Microsoft Word table with a CANopen compliant object description
'
'
    Dim cmbCategory As ContentControl
    Dim cmbObjectCode As ContentControl
    Dim cmbDataType As ContentControl
    Dim rng As Range
    
    ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=4, NumColumns:= _
        4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
    With Selection.Tables(1)
'        If .Style <> "Table Grid" Then
'            .Style = "Table Grid"
'        End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False

        .Range.ParagraphFormat.KeepWithNext = True
        .Range.ParagraphFormat.KeepTogether = True
        .Range.ParagraphFormat.SpaceBefore = 3
        .Range.ParagraphFormat.SpaceAfter = 3
        .Range.Font.Name = "Arial"
        .Range.Font.Size = 8
    
        .PreferredWidthType = wdPreferredWidthPoints
        .PreferredWidth = MillimetersToPoints(160)

        .Cell(1, 1).Merge MergeTo:=.Cell(2, 1)
        .Cell(3, 1).Merge MergeTo:=.Cell(4, 1)
        .Cell(1, 1).Shading.BackgroundPatternColor = RGB(128, 128, 128)
        .Cell(1, 2).Shading.BackgroundPatternColor = RGB(128, 128, 128)
        .Cell(2, 2).Shading.BackgroundPatternColor = RGB(128, 128, 128)
        .Cell(2, 3).Shading.BackgroundPatternColor = RGB(128, 128, 128)
        .Cell(2, 4).Shading.BackgroundPatternColor = RGB(128, 128, 128)

        Selection.Move Unit:=wdColumn, Count:=-1
        Selection.SelectColumn
        Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
        Selection.Columns.PreferredWidth = MillimetersToPoints(20)
        Selection.Move Unit:=wdColumn, Count:=1
        Selection.SelectColumn
        Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
        Selection.Columns.PreferredWidth = MillimetersToPoints(32)
        Selection.Move Unit:=wdColumn, Count:=1
        Selection.SelectColumn
        Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
        Selection.Columns.PreferredWidth = MillimetersToPoints(32)
        Selection.Move Unit:=wdColumn, Count:=1
        Selection.SelectColumn
        Selection.Columns.PreferredWidthType = wdPreferredWidthPoints
        Selection.Columns.PreferredWidth = MillimetersToPoints(76)

        .Cell(1, 1).Select
        Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
        Selection.Font.Bold = True
        Selection.Font.TextColor = vbWhite
        Selection.TypeText Text:="Index"

        ...

        .Cell(3, 2).Merge MergeTo:=.Cell(3, 4)

        Set rng = .Cell(4, 2).Range
        Set cmbCategory = rng.ContentControls.Add(wdContentControlComboBox)
        cmbCategory.Range.Text = "Select category"
        cmbCategory.SetPlaceholderText Text:=cmbCategory.Range.Text
        With cmbCategory
            .Title = "Category"
            .Tag = "Category"
            .DropdownListEntries.Clear
            .DropdownListEntries.Add Text:="mandatory", Value:="mandatory"
            .DropdownListEntries.Add Text:="optional", Value:="optional"
            .DropdownListEntries.Add Text:="conditional", Value:="conditional"
        End With
        Set rng = Nothing

        ...

    End With
    Set rng = Selection.Tables(1).Range
    rng.InsertCaption Label:="Table", Title:=" " + ChrW(8212) + " Object description", Position:=wdCaptionPositionAbove, ExcludeLabel:=0
    ActiveDocument.Range(rng.Start + Len("Table"), rng.Start + Len("Table") + 1).Text = ChrW(160)
    Set rng = Nothing

    Selection.MoveDown Count:=3
    Selection.TypeParagraph

End Sub