VBA Code Opening Word in Read-Only Mode

[Carin]

I'm attempting to run a macro in excel that copies data from named ranges into a Word Document using bookmarks. When running the below Macro, my Word files opens yet no changes are made. I believe it's because it opens in Read-Only mode. I have gone into options and checked and unchecked boxes to trust the document, etc. Can anyone look at my code to see if you can tell why it is doing this? I'm suspecting the code below in blue font, I found this code online to use a name cell with the file location. I'm not familiar with it.
Thank you!


Option Explicit

Sub MyMacro()

'Early Binding by preselecting Tools References Microsoft Word 16.0 Object Library

Dim WordApp As New Word.Application
Dim doc As Word.Document


Dim CTC_N_Received As Word.Range
Dim CTC_N_Validated As Word.Range
Dim CTC_N_Returned As Word.Range
Dim CTC_N_Awaiting As Word.Range

Dim CTC_P_Received As Word.Range
Dim CTC_P_Validated As Word.Range
Dim CTC_P_Returned As Word.Range
Dim CTC_P_Awaiting As Word.Range

Dim docPath As String

WordApp.Visible = True

Set doc = WordApp.Documents.Open([WordPath].Text, , True)

Set CTC_N_Received = doc.Bookmarks("CTC_N_Received").Range
CTC_N_Awaiting.Text = Range("CTC_N_Received").Value

Set CTC_N_Validated = doc.Bookmarks("CTC_N_Validated").Range
CTC_N_Awaiting.Text = Range("CTC_N_Validated").Value

Set CTC_N_Returned = doc.Bookmarks("CTC_N_Returned").Range
CTC_N_Awaiting.Text = Range("CTC_N_Returned").Value

Set CTC_N_Awaiting = doc.Bookmarks("CTC_N_Awaiting").Range
CTC_N_Awaiting.Text = Range("CTC_N_Awaiting").Value

Set CTC_P_Received = doc.Bookmarks("CTC_P_Received").Range
CTC_N_Awaiting.Text = Range("CTC_P_Received").Value

Set CTC_P_Validated = doc.Bookmarks("CTC_P_Validated").Range
CTC_N_Awaiting.Text = Range("CTC_P_Validated").Value

Set CTC_P_Returned = doc.Bookmarks("CTC_P_Returned").Range
CTC_N_Awaiting.Text = Range("CTC_P_Returned").Value

Set CTC_P_Awaiting = doc.Bookmarks("CTC_P_Awaiting").Range
CTC_N_Awaiting.Text = Range("CTC_P_Awaiting").Value




End Sub

 

[Trebor76]

probably you need to use scope "Workbook" for all to work.

Good thought but I tried that too and it still worked

 

[eduzs]

Could the document possibly be being opened in read-only mode due to access rights in this folder?

 

[eduzs]

Good thought but I tried that too and it still worked

If I change the scope of Bookmark1 from Workbook to a specific worksheet the code stop working, Error 1004 "Application-defined or Object-defined error".

 

[Trebor76]

Could the document possibly be being opened in read-only mode due to access rights in this folder?

You still should be able to write to the document just not save it. Maybe though if it's Citrix it may be an issue (I have found that FileSystemObject doesn't work on Citrix for example).

If I change the scope of Bookmark1 from Workbook to a specific worksheet the code stop working, Error 1004 "Application-defined or Object-defined error"

The following accounts for the two different methods of how a named range can be scoped. Let me know how it goes:

Option Explicit
Sub Macro1()

    Dim objWordApp As Object
    Dim objWordDoc As Object
    Dim objWordBkm As Object
    Dim varMyRange As Variant
           Dim nme As Name
  
    'Check if Word is already opened
    On Error Resume Next
        Set objWordApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            'If it isn't, open a new instance
            Set objWordApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
  
    Select Case FileStatus(ThisWorkbook.Names("WordPath").RefersToRange.Value)
        Case Is = 0 'File exists but is not open
            Set objWordDoc = objWordApp.Documents.Open(ThisWorkbook.Names("WordPath").RefersToRange.Value)
        Case Is = 70 'File is open
            Set objWordDoc = objWordApp.Documents(Dir(ThisWorkbook.Names("WordPath").RefersToRange.Value))
        Case Is = 53
            MsgBox "Invalid file name"
            Exit Sub
        Case Is = 76
            MsgBox "Invalid path"
            Exit Sub
    End Select
  
    'Make Word visible
    objWordApp.Visible = True
  
    'The array consists of the Excel named ranges and Word bookmarks which it is assumed are the same in both
    'It is only for a single cell
    For Each varMyRange In Array("CTC_N_Received", "CTC_N_Validated", "CTC_N_Returned", "CTC_N_Awaiting", _
                                 "CTC_P_Received", "CTC_P_Validated", "CTC_P_Returned", "CTC_P_Awaiting")
        For Each nme In ThisWorkbook.Names
            If InStr(CStr(nme.Name), CStr(varMyRange)) > 0 Then
                Set objWordBkm = objWordDoc.Bookmarks(CStr(varMyRange)).Range
                'https://stackoverflow.com/questions/8656793/programmatically-determine-if-a-named-range-is-scoped-to-a-workbook
                If TypeOf nme.Parent Is Worksheet Then 'Named range is scoped to a sheet
                    objWordBkm.Text = Range(CStr(nme.Name)).Value
                Else 'Named range is global to workbook
                    objWordBkm.Text = ThisWorkbook.Names(CStr(nme.Name)).RefersToRange.Value
                End If
                Exit For
            End If
        Next nme
    Next varMyRange
  
    Application.ScreenUpdating = True
  
End Sub
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Function FileStatus(strFileName As String) As Long

    Dim lngFileNum As Long
    Dim lngErr     As Long
   
    On Error Resume Next
        lngFileNum = FreeFile()
        Open strFileName For Input Lock Read As #lngFileNum
        Close lngFileNum
        FileStatus = Err
    On Error GoTo 0
   
End Function

Robert

 

[Trebor76]

In case anyone is following this thread, I sent a PM to Carin asking for the workbook where it seemed it was somehow corrupt because when I copied the data to a new workbook and ran the below code the data transferred as expected:

Option Explicit
Sub MyMacro()

    Dim strWordDocPath As String
    Dim strWordDocName As String
    Dim strWordDocDir  As String
    Dim strNamedRange As String
    Dim objWordApp As Object
    Dim objWordDoc As Object
    Dim objWordBkm As Object
    Dim objWordBkmRange As Object
    Dim varMyRange As Variant
    Dim rngMyData As Range
    Dim nme As Name

    'Check if Word is already opened
    On Error Resume Next
        Set objWordApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then
            'If it isn't, open a new instance of it
            Set objWordApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
  
    On Error Resume Next
        strWordDocPath = ThisWorkbook.Names(CStr("WordPath")).RefersToRange.Value
        If Len(strWordDocPath) = 0 Then
            strWordDocPath = Range(CStr("WordPath")).Value
        End If
    On Error GoTo 0
  
    strWordDocName = Replace(strWordDocPath, Left(strWordDocPath, InStrRev(strWordDocPath, Application.PathSeparator)), "")
    strWordDocDir = Left(strWordDocPath, InStrRev(strWordDocPath, Application.PathSeparator))
    
    Select Case FileStatus(strWordDocPath)
        Case Is = 0 'File exists but is not open
            Set objWordDoc = objWordApp.Documents.Open(strWordDocPath)
        Case Is = 70 'File is open
            Set objWordDoc = objWordApp.Documents(strWordDocName)
        Case Is = 53 'Invalid filename
            MsgBox "The entered file name..." & vbNewLine & """" & strWordDocName & """" & vbNewLine & "...is invalid." & vbNewLine & "Please check and try again.", vbExclamation, "Populate Word from Excel"
            Exit Sub
        Case Is = 76 'Invalid path
            MsgBox "The entered directory path..." & vbNewLine & """" & strWordDocDir & """" & vbNewLine & "...is invalid." & vbNewLine & "Please check and try again.", vbExclamation, "Populate Word from Excel"
            Exit Sub
    End Select
  
    Application.ScreenUpdating = False
  
    'Ensure the Word instance the document is in visible
    objWordApp.Visible = True
      
    'The array consists of the Excel named ranges and Word bookmarks which
    'it is assumed are the same in both
    'The code is only for a single cell's content to be copied to a Word bookmark.  The format of the cell is copied.
    'Note the bookmarks in the Word document need to be Enclosing Bookmarks
    'Placeholder Bookmarks will keep appending the data
    For Each varMyRange In Array("CTC_N_Received", "CTC_N_Validated", "CTC_N_Returned", "CTC_N_Awaiting", _
                                 "CTC_P_Received", "CTC_P_Validated", "CTC_P_Returned", "CTC_P_Awaiting")
        For Each nme In ThisWorkbook.Names
            If InStr(CStr(nme.Name), CStr(varMyRange)) > 0 Then
                If TypeOf nme.Parent Is Worksheet Then 'Named range is scoped to a sheet
                    Set objWordBkm = objWordDoc.Bookmarks(CStr(Split(nme.Name, "!")(1)))
                    objWordApp.Selection.GoTo What:=-1, Name:=objWordBkm.Name '-1 = wdGoToBookmark
                    Set objWordBkmRange = objWordBkm.Range
                    objWordBkmRange.Text = Replace(objWordBkmRange.Text, objWordBkmRange.Text, ThisWorkbook.Names(CStr(nme.Name)).RefersToRange.Text)
                    objWordDoc.Bookmarks.Add CStr(Split(nme.Name, "!")(1)), objWordBkmRange
                Else 'Named range is global to workbook
                    Set objWordBkm = objWordDoc.Bookmarks(CStr(nme.Name))
                    objWordApp.Selection.GoTo What:=-1, Name:=objWordBkm.Name '-1 = wdGoToBookmark
                    Set objWordBkmRange = objWordBkm.Range
                    objWordBkmRange.Text = Replace(objWordBkmRange.Text, objWordBkmRange.Text, ThisWorkbook.Names(CStr(nme.Name)).RefersToRange.Text)
                    objWordDoc.Bookmarks.Add CStr(nme.Name), objWordBkmRange
                End If
                Exit For
            End If
        Next nme
    Next varMyRange

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
  
    Set objWordApp = Nothing 'Release object from memory
  
    MsgBox "Excel data has been copied across to Word.", vbInformation, "Populate Word from Excel"

End Sub
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Function FileStatus(strFileName As String) As Long

    Dim lngFileNum As Long
    Dim lngErr     As Long
   
    On Error Resume Next
        lngFileNum = FreeFile()
        Open strFileName For Input Lock Read As #lngFileNum
        Close lngFileNum
        FileStatus = Err
    On Error GoTo 0
   
End Function

Note the formatting of cells in Excel is also copied to the bookmark which was important here as there were both percentages and whole numbers.

Robert

 

[Carin]

Thank you @Trebor76. Everything is now working beautifully.
Thank you @eduzs for your insight.

​