VBA文字添加标题

Question

我正在尝试使用 VBA 为 Word 文档添加标题。我正在使用以下代码。数据以 Excel 电子表格中的表格开始，每张表格一个。我们正在尝试在 word 文档中生成一个表格列表。

以下代码加载开始编辑单词模板：

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

以下代码循环遍历工作表中的工作表并添加表格和标题。

' 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

在单元格 B2 中，我有以下文本：“表 1：摘要”。我希望 word 文档有一个反映此文本的标题。问题是表号重复两次，我得到输出：“表 1：表 1：摘要”。我尝试了以下更改，均导致错误：

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

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

我做错了什么，更一般地说，insertcaption 方法是如何工作的？

我已经尝试阅读此内容，但对语法感到困惑。

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

Answer 1

在 MS Word 中使用标题样式的内置功能之一是它在文档中应用和动态调整的自动编号。您正在明确尝试自己管理表格编号 - 这很好 - 但您必须在代码中取消一些 Word 的自动有用编号。

在 Excel 中工作时，我测试了以下代码，以设置带有标题的测试文档，然后快速例行删除标签的自动部分。这个示例代码作为一个独立的测试来说明我是如何工作的，留给你去适应你自己的代码。

最初的test sub 简单地建立了Word.Application 和Document 对象，然后创建了三个带有以下段落的表。每个表格都有自己的标题（由于 Word 的自动标记，它显示了加倍的标签）。代码会抛出 MsgBox 来暂停，以便您在修改之前查看文档。

然后代码返回并在整个文档中搜索任何Caption 样式并检查样式中的文本以找到双标签。我假设如果在标题文本中检测到两个冒号“：”，则存在双标签。第一个标签（直到和超过第一个冒号）被删除并替换文本。这样，生成的文档如下所示：

代码：

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