「フォルダの参照」ダイアログを「常に手前」に表示

質問

下記サンプルを使ってフォルダを指定させています。

Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub

上記プログラムで働くダイアログを
常に手前に表示させるか、
モーダルにするか、
他の所がアクティブになっても、すぐに手前に表示させるかしたいのです。

ちなみにプログラムは
http://officetanaka.net/excel/vba/tips/tips39.htm
を参考にさせてもらっています。
（ちなみに「1.FileDialogオブジェクトを使う方法」はエクセル2002以降の機能らしく実行できませんでした。これを使えるのが一番いいのですが・・・）

エクセル　2000を使っています

よろしくおねがいします

回答No.3

nda23 · ベストアンサー

>Options属性で、フォルダ名を表示するテキストエリアを表示
あれはBROWSEINFO構造体のulFlagsへの設定値です。
よって、引数.ulFlags = BIF_RETURNONLYFSDIRS ～　に
追加する形で、BIF_EDITBOXを加算します。
どのフラグを使うとどうなるかは自分で試してください。
シンボルの値は全部書くと以下のようになります。

Const BIF_RETURNONLYFSDIRS　　　As Long = &H1
Const BIF_DONTGOBELOWDOMAIN　　 As Long = &H2
Const BIF_STATUSTEXT　　　　　　As Long = &H4
Const BIF_RETURNFSANCESTORS　　 As Long = &H8
Const BIF_EDITBOX　　　　　　　 As Long = &H10
Const BIF_VALIDATE　　　　　　　As Long = &H20
Const BIF_NEWDIALOGSTYLE　　　　As Long = &H40
Const BIF_BROWSEINCLUDEURLS　　 As Long = &H80
Const BIF_UAHINT　　　　　　　　As Long = &H100
Const BIF_NONEWFOLDERBUTTON　　 As Long = &H200
Const BIF_NOTRANSLATETARGETS　　As Long = &H400
Const BIF_BROWSEFORCOMPUTER　　 As Long = &H1000
Const BIF_BROWSEFORPRINTER　　　As Long = &H2000
Const BIF_BROWSEINCLUDEFILES　　As Long = &H4000
Const BIF_SHAREABLE　　　　　　 As Long = &H8000

また、RootFolderは同構造体のpidlRootメンバの
ことです。

お礼

おおお、できましたっ
わざわざ構造体の数値まで事細やかに教えてくださってありがとうございます。
おかげで色々いじれるようになりました。

回答No.2

nda23

以下のプログラムを標準モジュールに置きます。
「フォルダ検索」が本体で、親ウィンドウにExcelの
ウィンドウハンドルを指定すればモーダルになります。
ExcelのウィンドウはApplication.Hwndですが、手元に
Excel2000が無いので、サポートしているか不明です。
もし、無ければ「親ウィンドウ取得」を使って求めます。

Option Explicit
Const BFFM_INITIALIZED　　　As Long = 1
Const BFFM_SETSELECTIONA　　As Long = &H466
Const CSIDL_DESKTOP　　　　 As Long = 0
Const BIF_RETURNONLYFSDIRS　As Long = &H1
Const BIF_NEWDIALOGSTYLE　　As Long = &H40
Private Type BROWSEINFO
　　hwndOwner　　　 As Long
　　pidlRoot　　　　As Long
　　pszDisplayName　As String
　　lpszTitle　　　 As String
　　ulFlags　　　　 As Long
　　lpfn　　　　　　As Long
　　lParam　　　　　As Long
　　iImage　　　　　As Long
End Type
Private Declare Function SHBrowseForFolder Lib "Shell32" _
　　Alias "SHBrowseForFolderA" _
　　(引数 As BROWSEINFO) As Long
Private Declare Function SHILCreateFromPath Lib "Shell32" _
　　Alias "#28" _
　　(ByVal パス名 As Long, ID As Long, ByVal 属性 As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" _
　　Alias "SHGetPathFromIDListA" _
　　(ByVal ID As Long, ByVal パス領域 As String) As Long
Private Declare Function CoTaskMemFree Lib "OLE32" _
　　(ByVal ID As Long) As Long
Private Declare Function SetWindowText Lib "USER32" _
　　Alias "SetWindowTextA" _
　　(ByVal ウィンドウ As Long, ByVal 表題 As String) As Long
Private Declare Function SendMessage Lib "USER32" _
　　Alias "SendMessageA" _
　　(ByVal ウィンドウ As Long, ByVal メッセージ As Long, _
　　 ByVal Wパラメータ As Long, ByVal Lパラメータ As Long) As Long
Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenA" _
　　(ByVal 文字列 As String) As Long
Private Declare Function SysAllocStringByteLen Lib "OleAut32" _
　　(ByVal 文字列 As String, ByVal バイト数 As Long) As String
Private Declare Function GetCurrentProcessId Lib "KERNEL32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "USER32" _
　　(ByVal ウィンドウ As Long, プロセス As Long) As Long
Private Declare Function EnumWindows Lib "USER32" _
　　(ByVal コールバック As Long, Lパラメータ As Long) As Long
Private Declare Function GetClassName Lib "USER32" _
　　Alias "GetClassNameA" _
　　(ByVal ウィンドウ As Long, ByVal 名前 As String, ByVal 長さ As Long) As Long
Private Declare Function GetWindowText Lib "USER32" _
　　Alias "GetWindowTextA" _
　　(ByVal ウィンドウ As Long, ByVal 名前 As String, ByVal 長さ As Long) As Long
Private 表題 As String
Function フォルダ検索( _
　　Optional ByVal 親ウィンドウ As Long, _
　　Optional ByVal 初期フォルダ As String, _
　　Optional ByVal 説明文 As String, _
　　Optional ByVal タイトル As String) As String

Dim 引数 As BROWSEINFO
Dim ID　 As Long

引数.hwndOwner = 親ウィンドウ
引数.pidlRoot = CSIDL_DESKTOP
引数.pszDisplayName = Space(260)
引数.lpszTitle = 説明文
引数.ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE
If 初期フォルダ <> "" Then
　　SHILCreateFromPath StrPtr(初期フォルダ), 引数.lParam, 0
End If
引数.lpfn = アドレス応答(AddressOf フック)
表題 = タイトル
ID = SHBrowseForFolder(引数)
If ID <> 0 Then
　　SHGetPathFromIDList ID, 引数.pszDisplayName
　　フォルダ検索 = SysAllocStringByteLen(引数.pszDisplayName, _
　　　　　　　　　　　　　　　　lstrlen(引数.pszDisplayName))
　　CoTaskMemFree ID
End If
If 引数.lParam <> 0 Then CoTaskMemFree 引数.lParam
End Function
Private Function アドレス応答(ByVal アドレス As Long) As Long
アドレス応答 = アドレス
End Function
Function フック(ByVal ウィンドウ As Long, ByVal メッセージ As Long, _
ByVal Wパラメータ As Long, ByVal Lパラメータ As Long) As Long
If メッセージ = BFFM_INITIALIZED Then
　　If 表題 <> "" Then SetWindowText ウィンドウ, 表題
　　If Lパラメータ <> 0 Then
　　　　SendMessage ウィンドウ, BFFM_SETSELECTIONA, 0, Lパラメータ
　　End If
End If
End Function
Function 親ウィンドウ取得() As Long
Dim 親ウィンドウ As Long
EnumWindows AddressOf コールバック, 親ウィンドウ
親ウィンドウ取得 = 親ウィンドウ
End Function
Private Function コールバック( _
　　ByVal ウィンドウ As Long, _
　　親ウィンドウ As Long) As Long

Dim プロセス As Long
Dim クラス名 As String
Dim バイト数 As Long

コールバック = 1
GetWindowThreadProcessId ウィンドウ, プロセス
If プロセス = GetCurrentProcessId() Then
　　クラス名 = Space(128)
　　バイト数 = GetClassName(ウィンドウ, クラス名, Len(クラス名))
　　クラス名 = SysAllocStringByteLen(クラス名, バイト数)
　　If クラス名 = "XLMAIN" Then
　　　　親ウィンドウ = ウィンドウ
　　　　コールバック = 0
　　End If
End If
End Function

お礼

回答ありがとうございます

今自宅のパソコン(エクセル2007)で試してみて、無事動かせました。エクセル2000は会社の方なので明日試してみます

しかし、一つ気になったのが、私が質問文で使っていた

ShellObject.BrowseForFolder (Hwnd, Title, Options, [RootFolder])

という関数ですが、これにはOptionsという引数があり
Options属性で、フォルダ名を表示するテキストエリアを表示することができました。

これにはそれに該当する引数が見当たらなかったんですが、
これはあきらめるしかないんでしょうか？

回答No.1

piroin654

WindowsのAPIを使うようになります。以下に
方法が記載されています。

http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_110.html

お好きなように。

お礼

回答ありがとうございます

3番目のプログラムが非常に使い勝手がよさそうなのでそれを使わせてもらおうかと思います

しかし、一つ気になったのが、私が質問文で使っていた

ShellObject.BrowseForFolder (Hwnd, Title, Options, [RootFolder])

という関数ですが、これにはOptionsという引数があり
Options属性で、フォルダ名を表示するテキストエリアを表示することができました。

これにはそれに該当する引数が見当たらなかったんですが、
これはあきらめるしかないんでしょうか？