VBA word add caption - vba

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