Unable to update word document 2nd time through

[lution]

solved: Unable to update word document 2nd time through

When the user updates an option in their database, I'd like to push that option value into the user's merge documents. I've omitted the call to get things started but I basically call DoUpdateFileProperty with the property name and the new value. DoUpdateFileProperty then gets all the templates, calls DoesExist to see if the property is there (I don' push the property to all the templates). If the property is there, update it then call UpdateSpecificFields to update the visible text in the Word document.

It seems to work fine the first time I update a property. In watching the debug window, it shows me the right info and when its done, no Word processes are left running. The problem is, if I change an option without rebooting, the first time I hit a file that needs to be updated, I get an error #426, The remote server machine isn't available when it goes to update the field codes. If I look in task manager the WinWord process is still running and everything is local on the user's system. Nothing is running on a share.

For reference purposes, I'm using Office 2007 sp1 on Vista and I'm logged in as an administrator user.

Any ideas?

Public Sub UpdateSpecificFields(sFieldName As String)
Dim pRange As Word.Range
Dim oFld As Word.Field
Dim iLink As Long
iLink = Word.ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each pRange In ActiveDocument.StoryRanges
    Do
        For Each oFld In pRange.Fields
            Select Case oFld.type
                Case wdFieldDocProperty
                    If InStr(oFld.Code.Text, sFieldName) Then
                        oFld.Update
                    End If
                Case Else
                   'Do nothing
            End Select
        Next
        Set pRange = pRange.NextStoryRange
    Loop Until pRange Is Nothing
Next
End Sub
 
Public Function DoesExist(CDPN As String, sFile As String) As Boolean
Dim appWord As Word.Application
Dim doc As Word.Document
Dim PrCust As Object
Dim returnVal As Boolean
    returnVal = False
    Set appWord = New Word.Application
    Set doc = appWord.Documents.Open(sFile, , True, False, Visible:=False)
    For Each PrCust In doc.CustomDocumentProperties
        If PrCust.Name = CDPN Then
            returnVal = True
            Exit For
        End If
    Next
fin:
    Set doc = Nothing
    appWord.Quit
    Set appWord = Nothing
 
    DoesExist = returnVal
End Function
 
Public Sub DoUpdateFileProperty(sPropertyName As String, sPropertyValue As String, Optional sPropExists As Boolean = True)
Dim intWarning As Integer
Dim strTemplatePath As String
Dim strTemplateFile As String
Dim strSQL As String
Dim varFiles As Variant
Dim lngI As Long
Dim sExistingPropertyValue As String
Dim strFileExtension As String
Dim objWord As Word.Application
Dim objWordDoc As Word.Document
Dim propExists As Boolean
Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13
Const ERR_BADPROPERTY      As Long = 5
Const ERR_BADDOCOBJ        As Long = 438
Const ERR_BADCONTEXT       As Long = -2147467259
 
On Error GoTo Test_Err
    intWarning = vbYes
    ' Delete all the rows from the merge docs table
    If intWarning = vbYes Then
        DoCmd.Hourglass (True)
        DoCmd.OpenForm "frmStatus"
        Forms!frmStatus.txtStatus = "Gathering information . . . ."
        Pause 2
        ' Delete all the rows
        ' Get the template folder
        strTemplatePath = GetTemplatePath()
        ' Get the files in the template folder
        varFiles = GetAllFilesInDir(strTemplatePath)
 
        ' Start word
        Set objWord = CreateObject(Class:="Word.Application")
        objWord.Visible = False
 
        ' step through the files one by one
        For lngI = 0 To UBound(varFiles)
 
            strFileExtension = Right(strTemplatePath & varFiles(lngI), 4)
            'Debug.Print "Last 4 characters are :" & strFileExtension
            If (strFileExtension = ".dot") Or (strFileExtension = "dotx") Then
                Forms!frmStatus.txtStatus = "Updating " & varFiles(lngI) & " . . . ."
                Pause 0.1
 
                propExists = DoesExist(sPropertyName, strTemplatePath & varFiles(lngI))
 
                If propExists Then
                    Set objWordDoc = objWord.Documents.Open(strTemplatePath & varFiles(lngI))
 
                    sExistingPropertyValue = Trim(Nz(objWordDoc.CustomDocumentProperties.Item(sPropertyName).Value, ""))
                    Debug.Print "In IF for " & varFiles(lngI)
                    Debug.Print "Existing: " & objWordDoc.CustomDocumentProperties.Item(sPropertyName) & " new: " & sPropertyValue
                    objWordDoc.CustomDocumentProperties.Item(sPropertyName) = sPropertyValue
                    UpdateSpecificFields (sPropertyName)
                    objWordDoc.Close Word.WdSaveOptions.wdSaveChanges
                    Set objWordDoc = Nothing
                    ' objWordDoc.Close WdSaveOptions:=wdSaveChanges, WdOriginalFormat:=wdOriginalDocumentFormat
                    ' save the updated file
                    ' objWord.Documents(strTemplatePath & varFiles(lngI)).Close Word.WdSaveOptions.wdSaveChanges
                End If
            End If ' we have a word template
 
        Next lngI
 
        ' Close word
        objWord.Quit Word.WdSaveOptions.wdDoNotSaveChanges
        Set objWord = Nothing
 
        Forms!frmStatus.txtStatus = "Update complete . . . ."
        Forms!frmStatus.cmdCancel.Enabled = True
        Pause 2
        DoCmd.Close acForm, "frmStatus"
        DoCmd.Hourglass (False)
    End If
 
Test_Err:
    Select Case err.Number
        Case NO_FILES_IN_DIR
            MsgBox "The directory named '" & strTemplatePath _
                & "' does not contain any files."
        Case INVALID_DIR
            MsgBox "'" & strTemplatePath & "' is not a valid directory."
        Case ERR_BADDOCOBJ
            Debug.Print "Object does not support BuiltInProperties."
            Resume Next
        Case ERR_BADPROPERTY
            Debug.Print "Property not in collection."
        Case ERR_BADCONTEXT
            Debug.Print "Value not available in this context."
        Case 429
            'Word is not running; open Word with CreateObject
            Set objWord = CreateObject(Class:="Word.Application")
            Resume Next
        Case 0
        Case Else
            MsgBox "Error #" & err.Number & " - " & err.Description
    End Select
 
    DoCmd.Hourglass (False)
End Sub

 

[lution]

Since the document is already open (if its going to open) in the doupdate function, I changed the doesexist and updatespecificfields functions to take the word document as a parameter instead of the filename (that also speeded things up considerably).

DoUpdate - takes a property and the new value then loops through all the files in a folder. Calls doesexist to see if the property exists in the customproperties collection. If it does, update the custom property and then call updatespecificfields so the new text is displayed in the word document so the user doesn't have to remember to do that every time they use the file.

doesexist: Originally pulled from http://www.theofficeexperts.com/forum/archive/index.php/t-518.html

updatespecificfield: Originally pulled from http://gregmaxey.mvps.org/Field_Macros.htm, modified the unlink example to update the field instead of unlink it.

Thanks to Jal for pointing me towards needing to do a full declaration for any Word objects. Here's the working code in case anyone else needs something similar.

-Lution

Option Compare Database
Option Explicit
Public Sub UpdateSpecificFields(sFieldName As String, sFile As Word.Document)
Dim pRange As Word.Range
Dim oFld As Word.Field
' Dim iLink As Long
' iLink = sFile.Sections(1).Headers(1).Range.StoryType
For Each pRange In sFile.StoryRanges
    Do
        For Each oFld In pRange.Fields
            Select Case oFld.type
                Case Word.wdFieldDocProperty
                    If InStr(oFld.Code.Text, sFieldName) Then
                        oFld.Update
                    End If
                Case Else
                   'Do nothing
            End Select
        Next
        Set pRange = pRange.NextStoryRange
    Loop Until pRange Is Nothing
Next
 
End Sub
 
Public Function DoesExist(sPropName As String, sFile As Word.Document) As Boolean
Dim prop As Object
Dim returnVal As Boolean
    ' returns true if the sPropName is found in the CustomDocumentProperties collection
    ' otherwise returns false
    ' set the default return value
    returnVal = False
    ' loop through all the properties in the custom properties collection
    ' will set returnVal to true if we find it.
    For Each prop In sFile.CustomDocumentProperties
        If prop.Name = sPropName Then
            returnVal = True
            Exit For
        End If
    Next
    ' now set our function to the value we want to return
    DoesExist = returnVal
End Function
 
Public Sub DoUpdateFileProperty(sPropertyName As String, sPropertyValue As String, Optional sPropExists As Boolean = True)
Dim intWarning As Integer
Dim strTemplatePath As String
Dim strTemplateFile As String
Dim strSQL As String
Dim varFiles As Variant
Dim lngI As Long
Dim sExistingPropertyValue As String
Dim strFileExtension As String
Dim objWord As Word.Application
Dim objWordDoc As Word.Document
Dim propExists As Boolean
Dim sFileName As String
Dim sFullFileName As String
Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13
Const ERR_BADPROPERTY      As Long = 5
Const ERR_BADDOCOBJ        As Long = 438
Const ERR_BADCONTEXT       As Long = -2147467259
 
On Error GoTo Test_Err
    intWarning = vbYes
    ' Delete all the rows from the merge docs table
    If intWarning = vbYes Then
        DoCmd.Hourglass (True)
        DoCmd.OpenForm "frmStatus"
        Forms!frmStatus.txtStatus = "Gathering information . . . ."
        Pause 1
        ' Delete all the rows
        ' Get the template folder
        strTemplatePath = GetTemplatePath()
        ' Get the files in the template folder
        varFiles = GetAllFilesInDir(strTemplatePath)
 
        ' Start word
        Set objWord = GetObject(Class:="Word.Application")
        If objWord Is Nothing Then Set objWord = CreateObject("Word.Application")
        ' uncomment the next line when everything is working
        objWord.Visible = True
 
        ' step through the files one by one
        For lngI = 0 To UBound(varFiles)
 
            sFileName = CStr(varFiles(lngI))
            sFullFileName = strTemplatePath & sFileName
            strFileExtension = Right(sFullFileName, 4)
            'Debug.Print "Last 4 characters are :" & strFileExtension
            If (strFileExtension = ".dot") Or (strFileExtension = "dotx") Then
                Forms!frmStatus.txtStatus = "Updating " & varFiles(lngI) & " . . . ."
                ' Pause 0.1
                Debug.Print "Checking file: " & sFileName
 
                Set objWordDoc = objWord.Documents.Open(sFullFileName)
 
                propExists = DoesExist(sPropertyName, objWordDoc)
 
                If propExists Then
 
                    sExistingPropertyValue = Trim(Nz(objWordDoc.CustomDocumentProperties.Item(sPropertyName).Value, ""))
                    Debug.Print "In IF for " & varFiles(lngI)
                    Debug.Print "Existing: " & objWordDoc.CustomDocumentProperties.Item(sPropertyName) & " new: " & sPropertyValue
                    objWordDoc.CustomDocumentProperties.Item(sPropertyName) = sPropertyValue
                    Call UpdateSpecificFields(sPropertyName, objWordDoc)
                    objWordDoc.Close Word.WdSaveOptions.wdSaveChanges
                Else
                    objWordDoc.Close Word.WdSaveOptions.wdDoNotSaveChanges
                End If
 
                Set objWordDoc = Nothing
            End If ' we have a word template
 
        Next lngI
 
        ' Close word
        objWord.Quit Word.WdSaveOptions.wdDoNotSaveChanges
        Set objWord = Nothing
 
        Forms!frmStatus.txtStatus = "Update complete . . . ."
        Forms!frmStatus.cmdCancel.Enabled = True
        Pause 2
        DoCmd.Close acForm, "frmStatus"
        DoCmd.Hourglass (False)
    End If
 
Test_Err:
    Select Case err.Number
        Case NO_FILES_IN_DIR
            MsgBox "The directory named '" & strTemplatePath _
                & "' does not contain any files."
        Case INVALID_DIR
            MsgBox "'" & strTemplatePath & "' is not a valid directory."
        Case ERR_BADDOCOBJ
            Debug.Print "Object does not support BuiltInProperties."
            Resume Next
        Case ERR_BADPROPERTY
            Debug.Print "Property not in collection."
        Case ERR_BADCONTEXT
            Debug.Print "Value not available in this context."
        Case 429
            'Word is not running; open Word with CreateObject
            Set objWord = CreateObject(Class:="Word.Application")
            Resume Next
        Case 0
        Case Else
            MsgBox "Error #" & err.Number & " - " & err.Description
    End Select
 
    DoCmd.Hourglass (False)
End Sub