Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5942 / 76732

←次へ　｜　前へ→


	【76394】Re:フォルダが開かれているかどうか

独覚 - 14/11/18(火) 14:37 -


	引用なし

	パスワード

▼はてなさん：
標準モジュールに記載してください。
Sheet1のA1セルに記入されているパスがファイルエクスプローラーで開かれているかをチェックします。

「Sub DirChk()」の
>　　If CHK_FLG Then
>　　　　MsgBox "開いてない"
>　　Else
>　　　　MsgBox "開いてる"
>　　End If
に実際に行いたい処理を入れてください。
また、今は大文字・小文字の区別をしないようにしています。
区別させたい場合は
>'　　　　　　If CHK_DIR = CHK_Collection(Loop_CNT) Then　　'大文字(A)と小文字(a)を区別する
>　　　　　　If StrConv(CHK_DIR, vbUpperCase) = StrConv(CHK_Collection(Loop_CNT), vbUpperCase) Then
部分のコメントを逆にしてください。
なお、「Function getOpenDirList() As Collection」のほうは

ht tp://grayskybluesea.wordpress.com/2010/05/14/vba%E3%81%A7%E3%80%81%E9%
96%8B%E3%81%84%E3%81%A6%E3%81%84%E3%82%8B%E3%83%95%E3%82%A9%E3%83%AB%E3%83%
80%E3%83%91%E3%82%B9%E3%82%92%E5%85%A8%E3%81%A6%E5%8F%96%E5%BE%97%E3%81%99%
E3%82%8Bfunction/

を元にしています。
(ほとんどそのままですが)

Sub DirChk()

　　Dim CHK_DIR　　　　 As String
　　Dim CHK_FLG　　　　 As String
　　Dim CHK_Collection　As Collection
　　Dim CHK_DIR_CNT　　 As Integer
　　Dim Loop_CNT　　　　As Integer

　　CHK_DIR = Worksheets("Sheet1").Range("A1")

'　パスの最後に"\"があれば削除する
　　If Right(CHK_DIR, 1) = "\" Then
　　　　CHK_DIR = Left(CHK_DIR, Len(CHK_DIR) - 1)
　　End If
　　
　　Set CHK_Collection = getOpenDirList()
　　CHK_FLG = True
　　
　　CHK_DIR_CNT = CHK_Collection.Count
　　
　　If CHK_DIR_CNT > 0 Then
　　　　For Loop_CNT = 1 To CHK_DIR_CNT
'　　　　　　If CHK_DIR = CHK_Collection(Loop_CNT) Then　　'大文字(A)と小文字(a)を区別する

　　　　　　If StrConv(CHK_DIR, vbUpperCase) = StrConv(CHK_Collection(Loop_CNT), vbUpperCase) Then
　　　　　　　　CHK_FLG = False
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　End If
　　
　　If CHK_FLG Then
　　　　MsgBox "開いてない"
　　Else
　　　　MsgBox "開いてる"
　　End If
　　
End Sub

Function getOpenDirList() As Collection
　　Dim s　　　 As String
　　Dim res　　 As New Collection
　　Dim sh　　　As Object
　　Dim wcobj　 As Object
　　Dim wobj　　As Object
　　Dim result　As String
　　Dim i　　　 As Integer

'オブジェクトの取得
　　Set sh = CreateObject("Shell.Application")

'コレクションオブジェクトの取得
　　Set wcobj = sh.Windows

　　For Each wobj In wcobj
'Internt Explorerが開いているファイルは除外する。
　　　　If (wobj.FullName Like "*Explorer.EXE") = True Then
　　　　　　s = wobj.LocationURL
'オブジェクトフォルダは除外する
　　　　　　If Left(s, 10) <> "file:///::" Then
' 最初の"file:///"を取り除く
　　　　　　　　If s Like "file:///?:*" Then

'ローカル
　　　　　　　　　　s = Right(s, Len(s) - Len("file:///"))
　　　　　　　　Else

'サーバ
　　　　　　　　　　s = Right(s, Len(s) - Len("file:"))
　　　　　　　　End If

' 左から1文字ずつチェックして文字列を置き換えていく
　　　　　　　　result = ""
　　　　　　　　For i = 1 To Len(s)
　　　　　　　　　　Select Case Mid(s, i, 1)
　　　　　　　　　　　　Case "/"
　　　　　　　　　　　　　　result = result & "\"
　　　　　　　　　　　　Case "%"
　　　　　　　　　　　　　　result = result & Chr(CInt("&H" & Mid(s, i + 1, 2)))
　　　　　　　　　　　　　　i = i + 2
　　　　　　　　　　　　Case Else
　　　　　　　　　　　　　　result = result & Mid(s, i, 1)
　　　　　　　　　　End Select
　　　　　　　　Next
　　　　　　　　res.Add (result)

　　　　　　End If
　　　　End If
　　Next
　　Set getOpenDirList = res
End Function

0 hits

▼

【76393】フォルダが開かれているかどうか はてな 14/11/18(火) 12:08