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

i wrote the following code in VBA. I'm able to save the template onto the disk but the changes made are also made on the template which is then saved. I want to save the template with the information separately onto the disk and close the template without any changes being made to it. Also after I insert the details into header / footer, i used code to close the header / footer pane. That no longer works and now shows an extra page since i have separate header / footer for each page. How can i do this with the embedded word template since this worked if i kept the word template outside

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

CodePudding user response：

Side comment first: usually one would do what you want with mail merge in word ...

Regarding your question:

First of all - you should add a document (docx) as oleobject not a template (dotx). The template shows a somewhat strange behaviour.

Second it is necessary that you first do the saveAs, then open the new file to a separate doc-variable. By that the original oleObject-doc will not be edited.

Furthermore I would suggest two enhancements that make your code much more readable and more robust:

Insert a table for your data (= listobject in VBA) - then you can address the column-names in the code which is easier to maintain and to read than .cells(i,6).
You then can use these column names as tags for the content controls (ccs) in the word document. It is possible to name two different ccs with the same tag name. There is a method selectContentControlsByTag that returns all ccs with the same tag-name. Even those from headers and footers. So you should according ccs in the headers as well.

(Referencing a cc by index is critical as the index may change if you add a new cc or move them around or add text or ...)

As I understand you only insert some of the values to the letter. Therefore I suggest to postfix these column names e.g. by _cc.

This is the modified code - I added Microsoft Word as a reference to the VBA project.

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