【VBA】使用中ブックを誰が開いているか確認・表示する方法（ブックの共有不要）

Sub 編集者名表示()
'読み取り専用で開いたときに端末名か編集者名を表示する

    '＝＝＝＝＝＝定数指定＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
    '作業シートのIndex番号
    Const ShIndex    As Long = 1
    
    '編集端末名保存セル番地
    Const RecCell  As String = "C2"
    
    'ユーザーマスタの開始セル番地(入力欄の左上セル)
    Const UserCell As String = "B6"
    '＝＝＝＝＝＝定数指定＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
    
    On Error Resume Next
    With ThisWorkbook.Sheets(ShIndex)
    
        '読み取り専用の場合は使用者の端末名を表示して開くかどうか確認
        If ThisWorkbook.ReadOnly Then '読み取り専用だった場合
            
            '指定セル記録端末名の取得
            Dim PCName As String, BookName As String
            PCName = .Range(RecCell)
            BookName = ThisWorkbook.Name
            
            'ユーザーマスタ登録数取得
            Dim Er As Long, TopRng As Range
            Set TopRng = .Range(UserCell)
            For Er = .Cells(Rows.Count, TopRng.Column).End(xlUp).Row To 1 Step -1
                If .Cells(Er, TopRng.Column) <> "" Then Exit For
            Next Er
            
            'ユーザーマスタに登録がある場合はUserNameに編集者名を格納
            Dim i1 As Long, UserName As String
            For i1 = 1 To Er - TopRng.Row + 1
                If .Cells(i1 + .TopRng.Row - 1, TopRng.Column) = PCName Then
                    UserName = .Cells(i1 + TopRng.Row - 1, TopRng.Row + 1)
                    Exit For
                End If
            Next i1
            
            'UserName変数の内容によってメッセージの一部を変更
            If UserName = "" Then
                Msg1 = "使用端末は〈" & PCName & "〉です。"
            Else
                Msg1 = "使用者は〈" & UserName & "〉です。"
            End If
    
            '読み取り専用で開くか閉じるかの選択
            If MsgBox(BookName & "は編集のためロックされています。" & vbCrLf & _
                      Msg1 & vbCrLf & vbCrLf & _
                      "読み取り専用で開きますか？", _
                      vbQuestion + vbYesNo, "[使用中のファイル]") = vbNo Then
            
                '開いているBook数に応じて終了処理を分岐
                If Workbooks.Count = 1 Then
                    Application.Quit 'Excelを終了
                Else
                    ActiveWorkbook.Close 'WBのみ終了
                End If
                
            End If
        
        Else '読み取り専用でない場合は端末名を指定セルに保存
        
            '端末名取得
            Dim objNetWork As Object
            Set objNetWork = CreateObject("WScript.Network")
            .Range(RecCell) = objNetWork.ComputerName
            Set objNetWork = Nothing
            
            '上書き保存
            ThisWorkbook.Save
            
        End If
        
    End With
    
End Sub

'呼び出しコード
Private Sub Workbook_Open()
    Call 編集者名表示
End Sub

Dim xls
Dim fpath

fpath = "ここにExcelブックのフルパスを記載"

Set xls = CreateObject("Excel.Application")

xls.Visible = True
xls.WindowState = -4137
xls.Workbooks.Open fpath
Set xls = Nothing

Sub 編集端末表示()
'読み取り専用で開いたときに編集中端末名を表示する

    '＝＝＝＝＝＝定数指定＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
    '作業シートのIndex番号
    Const ShIndex   As Long = 1
    
    '編集端末名保存セル番地
    Const RecCell As String = "C2"
    '＝＝＝＝＝＝定数指定＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
    
    On Error Resume Next
    With ThisWorkbook.Sheets(ShIndex)
    
        '読み取り専用の場合は使用者の端末名を表示して開くかどうか確認
        If ThisWorkbook.ReadOnly Then '読み取り専用だった場合
            
            '指定セル記録端末名の取得
            Dim PCName As String, BookName As String
            PCName = .Range(RecCell)
            BookName = ThisWorkbook.Name
            
            '読み取り専用で開くか閉じるかの選択
            If MsgBox(BookName & "は編集のためロックされています。" & vbCrLf & _
                      "使用端末は〈" & PCName & "〉です。" & vbCrLf & vbCrLf & _
                      "読み取り専用で開きますか？", _
                      vbQuestion + vbYesNo, "[使用中のファイル]") = vbNo Then
            
                '開いているBook数に応じて終了処理を分岐
                If Workbooks.Count = 1 Then
                    Application.Quit 'Excelを終了
                Else
                    ActiveWorkbook.Close 'WBのみ終了
                End If
                
            End If
        
        Else '読み取り専用でない場合は端末名を指定セルに保存
        
            '端末名取得
            Dim objNetWork As Object
            Set objNetWork = CreateObject("WScript.Network")
            .Range(RecCell) = objNetWork.ComputerName
            Set objNetWork = Nothing
            
            '上書き保存
            ThisWorkbook.Save
            
        End If
        
    End With
    
End Sub

'呼び出しコード
Private Sub Workbook_Open()
    Call 編集端末表示
End Sub