wordを開いた後で読み取り専用にする

下記のコードをNormal.dotm テンプレートの標準モジュールにインポートする。

WinWord_Toggle_Read_Only.bas

Option Explicit
'起源: https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q12233198312
'参考: Excelの同機能 ※コメントのに[@]がある行は、参考にしたExcelにはない、独自の機能

Sub toggleReadOnly() '読み取り専用の設定/解除
'Private Sub toggleReadOnly() '読み取り専用の設定/解除

On Error GoTo ErrorHandler

    If IsPossibleSwitchReadOnly() = False Then
        GoTo Finally
    End If

    Dim activeDocumentFullName As String
    activeDocumentFullName = ActiveDocument.FullName

    Dim reActiveDocument As Document
    If ActiveDocument.ReadOnly Then
        If closeReadOnlyDocument() Then
            Set reActiveDocument = Documents.Open(activeDocumentFullName, ReadOnly:=False)
        End If
    Else
        If closeEditDocument() Then
            Set reActiveDocument = Documents.Open(activeDocumentFullName, ReadOnly:=True)
        End If
    End If

    GoTo Finally

ErrorHandler:
    MsgBox "実行時エラー '" & Err.Number & "':" & String(2, vbCrLf) & Err.Description, vbCritical
    Resume Finally

Finally:

End Sub

Private Function IsPossibleSwitchReadOnly() As Boolean

    Select Case True
        Case Not (MacroContainer.Parent.ActiveProtectedViewWindow Is Nothing)
            IsPossibleSwitchReadOnly = False
            Application.StatusBar = "このファイルは保護ビューで開かれました。" '[@]
        Case ActiveDocument.Path = ""
            IsPossibleSwitchReadOnly = False
            Application.StatusBar = "このドキュメントは保存されていません。" '[@]
        Case (GetAttr(ActiveDocument.FullName) And vbReadOnly) = vbReadOnly
            IsPossibleSwitchReadOnly = False
            MsgBox "'" & ActiveDocument.Name & "' は読み取り専用のため、上書き保存できません。" & String(2, vbCrLf) & "変更内容を維持するには、新しい名前でドキュメントを保存するか、別の場所に保存する必要があります。", vbExclamation
        Case Else
            IsPossibleSwitchReadOnly = True
    End Select

End Function

Private Function closeReadOnlyDocument() As Boolean 'Return: do close / do not close

'変更なし
    If ActiveDocument.Saved Then
        ActiveDocument.Close SaveChanges:=False
        closeReadOnlyDocument = True
        Exit Function
    End If

'変更あり
    Dim msg As String
    msg = msg & "'" & ActiveDocument.Name & "' を変更しました。" & vbCrLf
    msg = msg & "別の人も変更を加えました。どのように処理しますか？" & vbCrLf
    msg = msg & "変更内容を破棄して最新のファイルを編集する場合は、[はい] をクリックしてください。" & vbCrLf
    msg = msg & "変更内容を別のファイルに保存して最新のファイルを開く場合は、[いいえ] をクリックしてください。"

    Dim recv As String
    recv = MsgBox(msg, vbYesNoCancel + vbDefaultButton3, "変更されたファイル")

    Select Case recv
        Case vbYes
            ActiveDocument.Close SaveChanges:=False
            closeReadOnlyDocument = True
        Case vbNo
            With Application.FileDialog(msoFileDialogSaveAs)
                .InitialFileName = "コピー" & ActiveDocument.Name
                If .Show Then
                    If Dir(.SelectedItems(1)) = "" Then
                        .Execute '別名保存
                        ActiveDocument.Close SaveChanges:=False
                        closeReadOnlyDocument = True
                    Else
                        MsgBox "上書き保存できませんでした。" & vbCrLf & "(" & .SelectedItems(1) & ")", vbExclamation
                    End If
                End If
            End With
    End Select

End Function

Private Function closeEditDocument() As Boolean 'Return: do close / do not close

'変更なし
    If ActiveDocument.Saved Then
        ActiveDocument.Close SaveChanges:=False
        closeEditDocument = True
        Exit Function
    End If

    Const msg As String = "読み取り専用の切り替えを行う前に、編集内容を保存しますか？"

'変更あり
    Dim recv As String
    recv = MsgBox(msg, vbInformation + vbYesNoCancel + vbDefaultButton3)

    Select Case recv
        Case vbYes
            closeEditDocument = True
            ActiveDocument.Close SaveChanges:=True
        Case vbNo
            closeEditDocument = True
            ActiveDocument.Close SaveChanges:=False
        Case vbCancel '[@]
            closeEditDocument = False
    End Select

End Function