| |
▼はてな さん：
標準モジュールに記載してください。
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
