VBA 字添加标题

Question

我正在尝试使用 VBA 向 word 文档添加标题。我正在使用以下代码。数据以 table 开始，在 Excel 传播 sheet 中，每个 sheet 一个。我们正在尝试在 word 文档中生成 table 的列表。

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

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

以下代码循环遍历作品sheet中的sheet并添加table和header。

' 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 中，我有以下文本："Table 1: Summary"。我希望 word 文档有一个 header 来反映这段文字。问题是 table 数字重复了两次，我得到输出："Table 1: Table 1: Summary"。我尝试了以下更改，均导致错误：

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 中使用标题样式的 built-in 功能之一是它在您的文档中应用和动态调整的自动编号。您明确尝试自己管理 table 编号 - 这很好 - 但您随后必须 un-do 在您的代码中使用 Word 的一些自动帮助编号。

从 Excel 开始，我测试了下面的代码以设置带有字幕的测试文档，然后是一个快速例程来删除标签的自动部分。这个示例代码作为一个 stand-alone 测试来说明我是如何工作的，留给你去适应你自己的代码。

最初的test子简单地建立了Word.Application和Documentobjects，然后创建了三个table和下面的段落。每个 table 都有自己的标题（由于 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

VBA 字添加标题

VBA word add caption

vba

ms-word

caption