Merge to word using Doc Props & Template

[aimeepeter]

Hello all,
I am having trouble with my code to which merges a query to Word Template using Document Properties.

I am getting Error 5151: Word is unable to read this doucment. It may be corrupt.

When debugging the error is on the line:

docs.Add strWordTemplate

The template seems to work fine when I open it in word so perhaps there is something wrong with my code.

Any suggestions?

Here is the code:

Private Sub cmdContract_Click()
On Error GoTo Error_Handler

Dim appWord As Word.Application
Dim docs As Word.Documents
Dim strWordTemplate As String
Dim doc As Word.Document
Dim prps As Object
Dim prp As Object
Dim strShortDate As String
Dim strTemplatePath As String
Dim strTemplateNameAndPath As String
Dim strDocPath As String
Dim i As Integer
Dim intSaveNameFail As Boolean
Dim strSaveName As String
Dim strSaveNamePath As String
Dim strTestFile As String
Dim intAnswer As Integer
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File

Dim dbs As DAO.Database
Dim rst As DAO.Recordset

Dim strShowID As String

Dim strShowType As String
Dim strShowYear As String
Dim strShowCity As String
Dim strShowSeason As String
Dim strSeasonFullName As String
Dim strShowName As String
Dim strShowSubName As String
Dim strShowDate As String
Dim strShowTime As String
Dim str2ndShowTime As String
Dim strShowCallTime As String
Dim strShowBusTime As String
Dim strShowVenueName As String
Dim strKey As String
Dim strKeyPaymentTerms As String
Dim strCurrencySymbol As String
Dim strBudget As String
Dim strCurrencySuffix As String
Dim strSupport As String
Dim strProgramCredit As String
Dim strPaymentSuffix As String
Dim strSixth7th As String
Dim strSponsor As String
Dim strSponsorAmt As String
Dim strPhoto As String
Dim strVideo As String
Dim strSeats As String
Dim strFirstName As String
Dim strLastName As String
Dim strCompanyName As String
Dim strEmail As String
Dim strEmail1 As String
Dim strEmail2 As String


'Assign values to variables
 strShowID = Forms!frmShows.ShowID
 strShortDate = Format(Date, "dd-mmm-yy")
 
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SELECT * FROM qryPS1Contracts WHERE [ShowID] = " & strShowID & ";")

rst.MoveLast
rst.MoveFirst

'Turn off error handler because not all variable are present in each query
On Error Resume Next
 strShowType = Nz(rst!ShowType)
 strShowYear = Nz(rst!ShowYear)
 strShowCity = Nz(rst!ShowCity)
 strShowSeason = Nz(rst!ShowSeason)
 strSeasonFullName = Nz(rst!SeasonFullName)
 strShowName = Nz(rst!ShowName)
 strShowSubName = Nz(rst!ShowSubName)
 strShowDate = Nz(rst!ShowDate)
 strShowTime = Nz(rst!ShowTime)
 str2ndShowTime = Nz(rst![2ndShowTime])
 strShowCallTime = Nz(rst!ShowCallTime)
 strShowBusTime = Nz(rst!ShowBusTime)
 strShowVenueName = Nz(rst!ShowVenueName)
 strKey = Nz(rst!Key)
 strKeyPaymentTerms = Nz(rst!KeyPaymentTerms)
 strCurrencySymbol = Nz(rst!CurrencySymbol)
 strBudget = Nz(rst!Budget)
 strCurrencySuffix = Nz(rst!CurrencySuffix)
 strSupport = Nz(rst!Support)
 strProgramCredit = Nz(rst!ProgramCredit)
 strPaymentSuffix = Nz(rst!PaymentSuffix)
 strSixth7th = Nz(rst![Sixth7th])
 strSponsor = Nz(rst!Sponsor)
 strSponsorAmt = Nz(rst!SponsorAmt)
 strPhoto = Nz(rst!Photo)
 strVideo = Nz(rst!Video)
 strSeats = Nz(rst!Seats)
 strFirstName = Nz(rst!FirstName)
 strLastName = Nz(rst!LastName)
 strCompanyName = rst!CompanyName
 strEmail = Nz(rst!Email)
 strEmail1 = Nz(rst!EmailCC1)
 strEmail2 = Nz(rst!EmailCC2)
On Error GoTo Error_Handler

'Setup Template
strWordTemplate = "Contract TEMPLATE.dot"
strTemplatePath = GetContractTemplatePath
strTemplateNameAndPath = strTemplatePath & strWordTemplate
Debug.Print "Template Path and Name: " & strTemplatePath & strWordTemplate
 
'SetUp New Document
strSaveName = strShowName & " Contract " & strShowSeason & " " & strShowYear
strDocPath = GetContractPath
Debug.Print "New Document: " & strDocPath & strSaveName

 
'Try to locate template and put up a message if not found
On Error Resume Next
Set fil = fso.GetFile(strTemplateNameAndPath)
If fil Is Nothing Then
    MsgBox "Can't find the template " & strWordTemplate & " in " & strTemplatePath & vbCrLf & "Cannot create document.", _
    vbOKOnly + vbCritical, gstrAppTitle
    GoTo Exit_Procedure
End If
On Error GoTo Error_Handler

'Set Word Application variables
Set appWord = GetObject(Class:="Word.Application")
Set docs = appWord.Documents
docs.Add strWordTemplate
Set doc = appWord.ActiveDocument
Set prps = doc.CustomDocumentProperties
 
'Assign variable to doc properties
'Turn off error handler becasue not all variable are used
On Error Resume Next
 prps.Item("ShowType").Value = strShowType
 prps.Item("ShowYear").Value = strShowYear
 prps.Item("ShowCity").Value = strShowCity
 prps.Item("ShowSeason").Value = strShowSeason
 prps.Item("SeasonFullName").Value = strSeasonFullName
 prps.Item("ShowName").Value = strShowName
 prps.Item("ShowSubName").Value = strShowSubName
 prps.Item("ShowDate").Value = strShowDate
 prps.Item("ShowTime").Value = strShowTime
 prps.Item("Show2ndShowTime").Value = str2ndShowTime
 prps.Item("ShowCallTime").Value = strShowCallTime
 prps.Item("ShowBusTime").Value = strShowBusTime
 prps.Item("ShowVenueName").Value = strShowVenueName
 prps.Item("Key").Value = strKey
 prps.Item("KeyPaymentTerms").Value = strKeyPaymentTerms
 prps.Item("CurrencySymbol").Value = strCurrencySymbol
 prps.Item("Budget").Value = strBudget
 prps.Item("CurrencySuffix").Value = strCurrencySuffix
 prps.Item("Support").Value = strSupport
 prps.Item("ProgramCredit").Value = strProgramCredit
 prps.Item("PaymentSuffix").Value = strPaymentSuffix
 prps.Item("Sixth7th").Value = strSixth7th
 prps.Item("Sponsor").Value = strSponsor
 prps.Item("SponsorAmt").Value = strSponsorAmt
 prps.Item("Photo").Value = strPhoto
 prps.Item("Video").Value = strVideo
 prps.Item("Seats").Value = strSeats
 prps.Item("FirstName").Value = strFirstName
 prps.Item("LastName").Value = strLastName
 prps.Item("CompanyName").Value = strCompanyName
 prps.Item("tblContacts.EmailAddress1").Value = strEmail
 prps.Item("tblContacts_1.EmailAddress1").Value = strEmail1
 prps.Item("tblContacts_2.EmailAddress1").Value = strEmail2

 On Error GoTo Error_Handler
 
'Prepare New Document Name to Save
'Check if Document already exists and prompt to replace exisiting document or create a new version with incremental number
i = 2
intSaveNameFail = True
Do While intSaveNameFail
    strSaveNamePath = strDocPath & strSaveName
    Debug.Print "Proposed Save Path and Name: " & strSaveNamePath
    strTestFile = Nz(Dir(strSaveNamePath))
    Debug.Print "Test File: " & strTestFile
    If strTestFile = strSaveName Then
        Debug.Print "Save name already used: " & strSaveName
        intAnswer = MsgBox("The file " & strSaveName & " already exists. Do you want to replace this file? " & _
        "Select YES to replace the file. Select NO to create a new version.", vbYesNoCancel + vbExclamation, gstrAppTitle)
                Select Case intAnswer
                    Case vbCancel
                    GoTo Exit_Procedure
                    
                    Case vbYes
                    intSaveNameFail = False
                    
                    Case vbNo
                    intSaveNameFail = True
                    strSaveName = strSaveName & " ver" & CStr(i) & " " & strShortDate
                    strSaveNamePath = strDocPath & strSaveName
                    Debug.Print "New save path and name: " & strSaveNamePath
                    i = i + 1
                End Select
    Else
    Debug.Print "Save name not used: "; strSaveName
    intSaveNameFail = False
    End If
Loop

With appWord
    .Visible = True
    .Selection.WholeStory
    .Selection.Fields.Update
    Debug.Print "Going to save as: " & strSaveName
    .ActiveDocument.SaveAs strSaveNamePath
    .Activate
    .Selection.EndKey Unit:=wdStory
End With
          
                    
Exit_Procedure:
'Set appWord = Nothing
Exit Sub

Error_Handler:
If Err = 429 Then
    'Word is not running; open word with CreateObject
    Set appWord = CreateObject(Class:="Word.Application")
    Resume Next
Else
    MsgBox Err.Number & ", " & Err.Description
    Resume Exit_Procedure
    Resume
End If

End Sub


Public Function GetContractPath() As String
On Error GoTo Error_Handler

Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strPath As String

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tblPaperworkInfo")
rst.MoveFirst
strPath = Nz(rst![ContractDocsPath])

If Len(strPath) > 1 And Right(strPath, 1) <> "\" Then
    GetContractPath = strPath & "\"
Else
    GetContractPath = strPath
End If
rst.Close

Exit_Procedure:
    Exit Function
    
Error_Handler:
   MsgBox Err.Number & ", " & Err.Description
    Resume Exit_Procedure
    Resume

End Function

Cheers!