VBA word add caption

Question

I am trying to add captions to a word document, using VBA. I am using the following code. The data starts off as tables in an Excel spreadsheet, with one per sheet. We are trying to generate a list of tables in the word document.

The following code loads starts editing a word template:

Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add("Template path")

' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION

' Insert title
objWord.Selection.Font.Size = "16"
objWord.Selection.Font.Bold = True
objWord.Selection.TypeText ("Document name")
objWord.Selection.ParagraphFormat.SpaceAfter = 12
objWord.Selection.InsertParagraphAfter

The following code loops through the sheets in the worksheet and adds the tables and headers.

' Declaring variables
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim END_OF_STORY As Integer: END_OF_STORY = 6
Dim MOVE_SELECTION As Integer: MOVE_SELECTION = 0
Dim LastRow As Integer
Dim LastColumn As Integer
Dim TableCount As Integer
Dim sectionTitle As String: sectionTitle = " "

' Loading workbook
Set Wbk = Workbooks.Open(inputFileName)

' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION

' Looping through all spreadsheets in workbook
For Each Ws In Wbk.Worksheets

' Empty Clipboard
Application.CutCopyMode = False


objWord.Selection.insertcaption Label:="Table", title:=": " & Ws.Range("B2").Text

In the cell B2, I have the following text: "Table 1: Summary". I am hoping for the word document to have a header which reflects this text. The problem is the table number is repeated twice, and I get output: "Table 1: Table 1: Summary". I tried the following alterations, both of which resulted in errors:

objWord.Selection.insertcaption Label:="", title:="" & Ws.Range("B2").Text

objWord.Selection.insertcaption Label:= Ws.Range("B2").Text

What am I doing wrong, and more generally how does the insertcaption method work?

I have tried reading this, but am confused by the syntax.

https://msdn.microsoft.com/en-us/vba/word-vba/articles/selection-insertcaption-method-word

Answer 1

One of the built-in features of using the Caption style in MS Word is the automatic numbering it applies and dynamically adjust in your document. You are explicitly trying to manage the table numbering yourself - which is fine - but you'll then have to un-do some of Word's automatic helpful numbering in your code.

Working from Excel, I've tested the code below to set up a test document with Captions and then a quick routine to remove the automatic part of the label. This example code works as a stand-alone test to illustrate how I worked it, leaving it to you to adapt to your own code.

The initial test sub simply establishes the Word.Application and Document objects, then creates three tables with following paragraphs. Each of the tables has it's own caption (which shows the doubled up label, due to the automatic labeling from Word). The code throws up a MsgBox to pause so you can take a look at the document before it's modified.

Then the code goes back and searches the entire document for any Caption styles and examines the text within the style to find the double label. I made the assumption that a double label is present if there are two colons ":" detected in the caption text. The first label (up to and past the first colon) is removed and the text replaced. With that, the resulting document looks like this:

The code:

Option Explicit

Sub test()
    Dim objWord As Object
    Dim objDoc As Object
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    Set objDoc = objWord.documents.Add

    Dim newTable As Object
    Set newTable = objDoc.Tables.Add(Range:=objDoc.Range, NumRows:=3, NumColumns:=1)
    newTable.Borders.Enable = True
    newTable.Range.InsertCaption Label:="Table", Title:=": Table 1: summary xx"
    objDoc.Range.InsertParagraphAfter
    objDoc.Range.InsertAfter "Lorem ipsum"

    objDoc.Characters.Last.Select
    objWord.Selection.Collapse
    Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=2)
    newTable.Range.InsertCaption Label:="Table", Title:=": Table 2: summary yy"
    newTable.Borders.Enable = True
    objDoc.Range.InsertParagraphAfter
    objDoc.Range.InsertAfter "Lorem ipsum"

    objDoc.Characters.Last.Select
    objWord.Selection.Collapse
    Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=3)
    newTable.Range.InsertCaption Label:="Table", Title:=": Table 3: summary zz"
    newTable.Borders.Enable = True
    objDoc.Range.InsertParagraphAfter
    objDoc.Range.InsertAfter "Lorem ipsum"

    MsgBox "document created. hit OK to continue"

    RemoveAutoCaptionLabel objWord
    Debug.Print "-----------------"
End Sub

Sub RemoveAutoCaptionLabel(ByRef objWord As Object)
    objWord.Selection.HomeKey 6  'wdStory=6
    With objWord.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Style = "Caption"
        .Text = ""
        .Forward = True
        .Wrap = 1            'wdFindContinue=1
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        Do While .Execute()
            RemoveDoubleLable objWord.Selection.Range
            objWord.Selection.Collapse 0   'wdCollapseEnd=0
        Loop
    End With
End Sub

Sub RemoveDoubleLable(ByRef capRange As Object)
    Dim temp As String
    Dim pos1 As Long
    Dim pos2 As Long
    temp = capRange.Text
    pos1 = InStr(1, temp, ":", vbTextCompare)
    pos2 = InStr(pos1 + 1, temp, ":", vbTextCompare)
    If (pos1 > 0) And (pos2 > 0) Then
        temp = Trim$(Right$(temp, Len(temp) - pos1 - 1))
        capRange.Text = temp
    End If
End Sub