ＥＸＣＥＬ ＶＢＡについて（再質問）

質問

お世話になります。
EXCEL VBAで指定したフォルダのEXCELブックが１つでもオープンされているかどうか知りたいのですが、可能でしょうか。

という質問を行い、以下の回答をいただきました。

自分でテストしてみてできたと思ったのですが、
他の人が開いているのが分かりませんでした。

他の人がオープンしているかどうか知ることは可能でしょうか？
よろしくお願いします。

以下の回答といただきました。
－－－－－－－－－－－－－
※[ツール]-[参照設定]で
Microsoft Scripting Runtimeにチェック入れて下さい。

Dim Fso As New FileSystemObject 'ファイルシステムオブジェクト
Dim xlBook As Workbook '開かれているブック
Dim objFolder As Folder '調べるフォルダ
Dim bOpenedBook As Boolean '開かれているかフラグ

'調べるフォルダを「C:\tmp」とする。
Set objFolder = Fso.GetFolder("C:\tmp")

bOpenedBook = False

'今開かれているブックでループする。
For Each xlBook In Excel.Workbooks
If Len(xlBook.Path) > 0 Then
'ブックが保存されているフォルダと調べるフォルダが一致するか？
If objFolder Is Fso.GetFolder(xlBook.Path) Then
'一致すれば開かれている
bOpenedBook = True
Exit For
End If
End If
Next

'結果をメッセージボックスで表示
If bOpenedBook Then
MsgBox "開かれています。"
Else
MsgBox "一つも開かれていません。"
End If

回答No.3

pen_pen_pen · ベストアンサー

ごめんなさい。実はその方法ですと、自分が開いていてもチェックできないんですよね。
という訳で考え直しました。

Dim Fso As New FileSystemObject
Dim Fl As File
Dim objFolder As Folder '調べるフォルダ
Dim bOpenedBook As Boolean

'調べるフォルダを「C:\tmp」とする。
Set objFolder = Fso.GetFolder("C:\tmp")

bOpenedBook = False

'フォルダ内の全ファイルでループ
For Each Fl In objFolder.Files

'拡張子が「xls」のものだけ調べる
If StrComp(Fso.GetExtensionName(Fl.Path), "xls", vbTextCompare) = 0 Then

'同じ名前でファイル名を変更しようとしてみる
On Error Resume Next
Name Fl.Path As Fl.Path
If Err.Number <> 0 Then
On Error Goto 0
'エラーが発生すれば排他制御が掛かっている（＝開かれている？）
bOpenedBook = True
Exit For
End If
On Error Goto 0
End If
Next

Set Fl = Nothing
Set objFolder = Nothing
Set Fso = Nothing

'結果をメッセージボックスで表示
If bOpenedBook Then
MsgBox "開かれています。"
Else
MsgBox "一つも開かれていません。"
End If

お礼

回答ありがとうございます。
やってみますね。

補足

ありがとうございました。できました。連絡遅くなってしまい申し訳ありませんでした。

回答No.2

KenKen_SP

こんにちは。KenKen_SP です。

こんな感じで、排他モードでファイルを開らくとき、ファイルが使用中であれ
ばエラーとなるのを利用します。ただし、この方法単独では、自分で開いてい
るのか、別の人が開いているのかは区別されません。

これを区別するなら、ご質問分にあるコードなどを使って、2段チェックする
必要があります。

Sub Sample()

　　Dim strDirectory As String
　　Dim strXLSpath　 As String

　　' チェックするフォルダパス
　　strDirectory = "C:\tmp"

　　strXLSpath = Dir(strDirectory & "\*.xls", vbNormal)

　　While strXLSpath <> vbNullString
　　　　strXLSpath = strDirectory & "\" & strXLSpath
　　　　' このマクロが書かれたブック＝ Thisworkbook は除外する
　　　　If StrComp(strXLSpath, ThisWorkbook.FullName, vbTextCompare) <> 0 Then
　　　　　　' 既に開かれているかチェック
　　　　　　If OpenedFile(strXLSpath) Then
　　　　　　　　blnFlag = True
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　　　' 次のファイルを検索
　　　　strXLSpath = Dir()
　　Wend

　　' 結果出力
　　If blnFlag Then
　　　　MsgBox "既に開かれたブックがあります"
　　Else
　　　　MsgBox "一つも開かれておりません."
　　End If

End Sub

' フルパスで渡したファイルが開かれていれば True を返す
Private Function OpenedFile(ByRef strFilepath As String) As Long

　　Dim n As Integer

　　n = FreeFile()
　　On Error Resume Next
　　Open strFilepath For Binary Access Read Lock Read As #n
　　Close #n
　　Select Case Err.Number
　　　　Case 52:　 Err.Raise 1000, , "パスが不正です."
　　　　Case 70:　 OpenedFile = True　 ' ファイルは使用中
　　　　Case 0:　　OpenedFile = Flase　' ファイルは使われていない
　　　　Case Else: Err.Raise Err.Number, , Err.Description
　　End Select
　　On Error GoTo 0

End Function

回答No.1

noname#230891

他で開かれているかどうかは、そのブックを一旦開いてみて
読み取り専用になったかどうかで判断するしかないと思います。
DisplayAlertsプロパティあたりを制御して「無理矢理」開いて、
開いたブックのReadOnlyプロパティを調べてみてはいかがでしょう。