Find and replace a text string in protected rtf Word document

Question

When running the VBA code below on a folder that contains approximately 100 rtf Word documents, I receive the following VBA error.

"Run-time error '4605' This method or property is not available
because the object refers to a protected area of the document."

The code may no longer be compatible or the best code for this job but it worked a few years ago.

The code uses find and replace to update any rtf documents within the folder. The code searches the body of each rtf document for the word CAT and replaces with DOG.

After receiving the error and looking at debug, the last line of the VBA code is highlighted.

.Execute Replace:=wdReplaceAll

Many of the documents within the folder are 'protected from unintentional editing. You may only fill in the forms region' -- this can be overridden from within the file by selecting the 'Stop Protection' button.
There is nothing in my code to override this protection. Is there code which would stop enforcing 'Restrict Editing' when the code is running the 'Start Enforcing Protection' on the files after the code finishes?

Here is a screenshot of the 'Restrict Editing' protection that is checked on many of the documents:

The restriction checked under 'Restrict Editing' in many of the documents is 'Allow only this type of editing in the document: FILLING IN FORMS'.

My guess is the macro would need to uncheck this on each document within the folder if that box is checked then recheck that box near the end of the macro.

Full code below.

Sub UpdateBODY()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document, Rng As Range
Dim Sctn As Section, HdFt As HeaderFooter, Fnd As String, Rep As String
Fnd = "CAT": Rep = "DOG"
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.rtf", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
  With wdDoc
    'Process everything except headers & footers
    For Each Rng In .StoryRanges
      Select Case Rng.StoryType
        Case wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory, _
          wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory
        Case Else
          Call RngFndRep(Rng, Fnd, Rep)
      End Select
    Next
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub RngFndRep(Rng As Range, Fnd As String, Rep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .Wrap = wdFindContinue
  .Text = Fnd
  .Replacement.Text = Rep
  .MatchCase = True
  .MatchAllWordForms = False
  .MatchWholeWord = False
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
End With
End Sub

Answer 1

You need to use the Document.Protect function. The first step is to record the current ProtectionType as this will enable reapplying it before the document is closed. The next step is to check the protection type to see if the document needs to be unprotected. Finally, before closing the docuemnt, the recorded protection type needs to be checked to see if protection needs to be re-applied.

NOTE: this code will only work if the protection has been applied without a password. If a password has been used it will need to be passed to the protect method. See documentation: https://learn.microsoft.com/en-us/office/vba/api/Word.document.protect

Sub UpdateBODY()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, wdDoc As Document, Rng As Range
    Dim Sctn As Section, HdFt As HeaderFooter, Fnd As String, Rep As String
    Dim protection As Long
    Fnd = "CAT": Rep = "DOG"
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.rtf", vbNormal)
    While strFile <> ""
        Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
        With wdDoc
            'record current protection type and unprotect if necessary
            protection = .ProtectionType
            If protection <> wdNoProtection Then .Protect wdNoProtection
            'Process everything except headers & footers
            For Each Rng In .StoryRanges
                Select Case Rng.StoryType
                    Case wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory, _
                        wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory
                    Case Else
                        Call RngFndRep(Rng, Fnd, Rep)
                End Select
            Next
            'reapply protection if necessary
            If protection <> wdNoProtection Then .Protect protection
            .Close SaveChanges:=True
        End With
        strFile = Dir()
    Wend
    Set wdDoc = Nothing
    Application.ScreenUpdating = True
End Sub