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中，我有以下文字：＆＃34;表1：摘要＆＃34;。我希望word文档有一个反映这个文本的标题。问题是表号重复两次，我得到输出：＆＃34;表1：表1：摘要＆＃34;。我尝试了以下改动，这两种改变都导致了错误：

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子只是建立Word.Application和Document个对象，然后创建三个包含以下段落的表。每个表都有它自己的标题（由于Word自动标记，它显示了加倍的标签）。该代码会抛出MsgBox暂停，以便您可以在文档修改之前查看该文档。

然后代码返回并在整个文档中搜索任何Caption样式，并检查样式中的文本以查找双标签。我假设如果有两个冒号，则会出现双重标签＆＃34;：＆＃34;在标题文本中检测到。删除第一个标签（直到和超过第一个冒号）并替换文本。有了它，结果文档如下所示：

代码：

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单词添加标题

1 个答案: