编辑嵌入的 word 模板并保存它而不对模板进行任何更改

Question

我在VBA写了下面的代码。我可以将模板保存到磁盘上，但所做的更改也会在模板上进行，然后保存。我想将带有信息的模板单独保存到磁盘上，然后关闭模板而不对其进行任何更改。同样在我将详细信息插入页眉/页脚之后，我使用代码关闭了页眉/页脚窗格。这不再有效，现在显示一个额外的页面，因为我为每个页面都有单独的页眉/页脚。我如何使用嵌入的单词模板执行此操作，因为如果我将单词模板放在外面就可以了

Private Sub M114_Click()

Dim oleObject As Object
Dim wDoc As Object

Set oleObject = ActiveWorkbook.Sheets("Properties").OLEObjects(1)
oleObject.Verb Verb:=xlPrimary
ActiveSheet.Range("A1").Select
Set wDoc = oleObject.Object

' Creates the last row that will be used
'lRow = ThisWorkbook.Sheets("Input").Cells(Rows.Count, 1).End(xlUp).Row
' Loop through all the rows
'For i = 3 To lRow


i = 3

' Control 1/21 - Date of Letter
wDoc.ContentControls(1).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)
wDoc.ContentControls(21).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 2)

' Control 2/14 - Bank Contact Name
wDoc.ContentControls(2).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)
wDoc.ContentControls(14).Range.Text = ThisWorkbook.Sheets("Input").Cells(i, 13)


' Update Headers from page 3 to page 5
For j = 3 To 5
With wDoc.Sections(j).Headers(wdHeaderFooterPrimary).Range
    .InsertAfter Text:=vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 6))
    .InsertAfter vbTab
    .InsertAfter Text:=vbCrLf & vbCrLf & UCase(ThisWorkbook.Sheets("Input").Cells(i, 7))
    .InsertAfter vbTab
    .InsertAfter Text:=vbCrLf & vbCrLf & ("At close of business on 31 December " & DatePart("yyyy", ThisWorkbook.Sheets("Input").Cells(i, 4)))
End With
Next j

'''' Issue with this resolve this

' Close the header / footer pane
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
wDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument


' Create the file name and save and close the file
file_name = Application.WorksheetFunction.Trim("BankConf-" & ThisWorkbook.Sheets("Input").Cells(i, 6) & "-" & ThisWorkbook.Sheets("Input").Cells(i, 7) & ".doc")
wDoc.SaveAs2 (ThisWorkbook.Path & "/" & file_name)

'wDoc.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

wDoc.Application.Quit

Answer 1

旁注第一：通常人们会用 mail merge 在 word 中做你想做的事 ...

关于您的问题：

首先 - 您应该将文档 (docx) 添加为 oleobject 而不是模板 (dotx)。该模板表现出一些奇怪的行为。

其次，您必须首先执行saveAs，然后将新文件打开到单独的doc-variable。原来的oleObject-doc不会被编辑。

此外，我建议进行两项改进，使您的代码更具可读性和健壮性：

为你的数据插入一个table（=listobject in VBA）——然后你可以在代码中解决column-names这样更容易维护和阅读比 .cells(i,6).
然后您可以将这些列名用作 word 文档中内容控件 (ccs) 的标签。可以用相同的标签名称命名两个不同的 cc。有一种方法 selectContentControlsByTag 可以 returns 所有具有相同 tag-name 的抄送。甚至来自 headers 和页脚的那些。所以你也应该根据 headers 中的 ccs。

（按索引引用 cc 很重要，因为如果您添加新的 cc 或移动它们或添加文本或...，索引可能会更改）

据我了解，您只在字母中插入了一些值。因此，我建议为这些列名称添加后缀，例如通过 _cc.

这是修改后的代码 - 我添加了 Microsoft Word 作为对 VBA 项目的引用。

Option Explicit

Sub createAll()

Dim docSource As Word.Document
Set docSource = getSourceDoc    'from oleObject

'assumption your data are in a table --> insert > table
'column names that have values that should go into the letter are named [CC-Tag]_CC
'example: columns name = DateOfLetter_CC | content controls tag= DateOfLetter

Dim lo As ListObject
Set lo = ThisWorkbook.Sheets("Input").ListObjects(1)


Dim lr As ListRow, lc As ListColumn
Dim docTarget As Word.Document, cc As ContentControl

'loop all rows of data table
For Each lr In lo.ListRows
    'get empty word doc for this entry
    Set docTarget = getTargetDoc(docSource, getFullFilename(lr))

    For Each lc In lo.ListColumns
        'within the word doc each CC has an according tag (without postfix)
        If Right(lc.Name, 3) = "_CC" Then
            For Each cc In docTarget.SelectContentControlsByTag(Split(lc.Name, "_")(0))
                'there can be multiple CCs with the same tag
                'tags within headers/footers are also handled within this loop
                cc.Range.Text = lr.Range.Cells(1, lc.Index)
            Next
        End If
    Next
    docTarget.Close True
Next

'close Word
docSource.Application.Quit

MsgBox "ready"

End Sub

Private Function getFullFilename(lr As ListRow) As String
'you have to adjust this to your needs, i.e. add the correct column names to build the filename
Dim lo As ListObject
Set lo = lr.Parent
With lr.Range
    getFullFilename = ThisWorkbook.Path & "\" & .Cells(1, lo.ListColumns("BankContactName_CC").Index).Value & ".docx"
End With
End Function

Private Function getSourceDoc() As Word.Document
'retrieves the oleDoc which is later used to save copies from

Dim oleObject As oleObject
Set oleObject = ThisWorkbook.Sheets("Properties").OLEObjects(1)

oleObject.Verb xlVerbOpen

Set getSourceDoc = oleObject.Object
End Function


Private Function getTargetDoc(docSource As Word.Document, FullFilename As String) As Word.Document
'saveas new file - open new file
'this is then returned

docSource.SaveAs2 FullFilename

Dim wrdApp As Word.Application
Set wrdApp = docSource.Application

Set getTargetDoc = wrdApp.Documents.Open(FullFilename)

End Function

编辑嵌入的 word 模板并保存它而不对模板进行任何更改

Editing an embedded word template and saving it without any changes being made to template

excel

vba

ms-word

object