SHBrowseForFolder クラス
名づけて、VB 汎用モジュール アーカイブプロジェクト、第一弾です。いつまでもVB6使ってますが、有用なモジュールが結構たまっているのでちょっとづつ整理して行こうと思っています。
このモジュールは以下のようにしてフォルダ選択ダイアログを表示します。ちゃんと初期フォルダも選択されます。
Private Sub Command1_Click()
Dim objBrowse As New CBrowseFolder
objBrowse.Flags = BIF_NEWDIALOGSTYLE
objBrowse.InitDir = CurDir()
Set objBrowse.Owner = Me
objBrowse.RootFolder = CSIDL_DESKTOP
objBrowse.Title = "あなたの一番大事なフォルダを選択してください"
Call MsgBox(objBrowse.Show())
End Sub
メインのクラスモジュール CBrowseFolder.cls です。ポイントは BROWSEINFO 構造体の lParam に自身のポインタを格納しておくことです。これによってコールバックプロシージャより、呼びもとのインスタンスを参照することができます。これさえできれば自由自在ですよね。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "CBrowseFolder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const mcstrMODULE_NAME As String = "CBrowseFolder"
Private Const MAX_PATH As Long = 260&
Private Type tagBROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" ( _
lpBrowseInfo As tagBROWSEINFO _
) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" ( _
ByVal pidl As Long, _
ByRef pszPath As Any _
) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" ( _
ByVal pv As Long _
)
Public Enum gEnumBrowseInfoFlag
'// Browsing for directory.
BIF_RETURNONLYFSDIRS = &H1& '// For finding a folder to start document searching
BIF_DONTGOBELOWDOMAIN = &H2& '// For starting the Find Computer
BIF_STATUSTEXT = &H4& '// Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if
'// this flag is set. Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the
'// rest of the text. This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets
'// all three lines of text.
BIF_RETURNFSANCESTORS = &H8&
BIF_EDITBOX = &H10& '// Add an editbox to the dialog
BIF_VALIDATE = &H20& '// insist on valid result (or CANCEL)
BIF_NEWDIALOGSTYLE = &H40& '// Use the new dialog layout with the ability to resize
'// Caller needs to call OleInitialize() before using this API
BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
BIF_BROWSEINCLUDEURLS = &H80& '// Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)
BIF_UAHINT = &H100& '// Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX
BIF_NONEWFOLDERBUTTON = &H200& '// Do not add the "New Folder" button to the dialog. Only applicable with BIF_NEWDIALOGSTYLE.
BIF_NOTRANSLATETARGETS = &H400& '// don't traverse target as shortcut
BIF_BROWSEFORCOMPUTER = &H1000& '// Browsing for Computers.
BIF_BROWSEFORPRINTER = &H2000& '// Browsing for Printers
BIF_BROWSEINCLUDEFILES = &H4000& '// Browsing for Everything
BIF_SHAREABLE = &H8000& '// sharable resources displayed (remote shares, requires BIF_USENEWUI)
End Enum
Public Enum gEnumCSIDL
CSIDL_DESKTOP = &H0& '// <desktop>
CSIDL_INTERNET = &H1& '// Internet Explorer (icon on desktop)
CSIDL_PROGRAMS = &H2& '// Start Menu\Programs
CSIDL_CONTROLS = &H3& '// My Computer\Control Panel
CSIDL_PRINTERS = &H4& '// My Computer\Printers
CSIDL_PERSONAL = &H5& '// My Documents
CSIDL_FAVORITES = &H6& '// <user name>\Favorites
CSIDL_STARTUP = &H7& '// Start Menu\Programs\Startup
CSIDL_RECENT = &H8& '// <user name>\Recent
CSIDL_SENDTO = &H9& '// <user name>\SendTo
CSIDL_BITBUCKET = &HA& '// <desktop>\Recycle Bin
CSIDL_STARTMENU = &HB& '// <user name>\Start Menu
CSIDL_MYDOCUMENTS = &HC& '// logical "My Documents" desktop icon
CSIDL_MYMUSIC = &HD& '// "My Music" folder
CSIDL_MYVIDEO = &HE& '// "My Videos" folder
CSIDL_DESKTOPDIRECTORY = &H10& '// <user name>\Desktop
CSIDL_DRIVES = &H11& '// My Computer
CSIDL_NETWORK = &H12& '// Network Neighborhood (My Network Places)
CSIDL_NETHOOD = &H13& '// <user name>\nethood
CSIDL_FONTS = &H14& '// windows\fonts
CSIDL_TEMPLATES = &H15&
CSIDL_COMMON_STARTMENU = &H16& '// All Users\Start Menu
CSIDL_COMMON_PROGRAMS = &H17& '// All Users\Start Menu\Programs
CSIDL_COMMON_STARTUP = &H18& '// All Users\Startup
CSIDL_COMMON_DESKTOPDIRECTORY = &H19& '// All Users\Desktop
CSIDL_APPDATA = &H1A& '// <user name>\Application Data
CSIDL_PRINTHOOD = &H1B& '// <user name>\PrintHood
CSIDL_LOCAL_APPDATA = &H1C& '// <user name>\Local Settings\Applicaiton Data (non roaming)
CSIDL_ALTSTARTUP = &H1D& '// non localized startup
CSIDL_COMMON_ALTSTARTUP = &H1E& '// non localized common startup
CSIDL_COMMON_FAVORITES = &H1F&
CSIDL_INTERNET_CACHE = &H20&
CSIDL_COOKIES = &H21&
CSIDL_HISTORY = &H22&
CSIDL_COMMON_APPDATA = &H23& '// All Users\Application Data
CSIDL_WINDOWS = &H24& '// GetWindowsDirectory()
CSIDL_SYSTEM = &H25& '// GetSystemDirectory()
CSIDL_PROGRAM_FILES = &H26& '// C:\Program Files
CSIDL_MYPICTURES = &H27& '// C:\Program Files\My Pictures
CSIDL_PROFILE = &H28& '// USERPROFILE
CSIDL_SYSTEMX86 = &H29& '// x86 system directory on RISC
CSIDL_PROGRAM_FILESX86 = &H2A& '// x86 C:\Program Files on RISC
CSIDL_PROGRAM_FILES_COMMON = &H2B& '// C:\Program Files\Common
CSIDL_PROGRAM_FILES_COMMONX86 = &H2C& '// x86 Program Files\Common on RISC
CSIDL_COMMON_TEMPLATES = &H2D& '// All Users\Templates
CSIDL_COMMON_DOCUMENTS = &H2E& '// All Users\Documents
CSIDL_COMMON_ADMINTOOLS = &H2F& '// All Users\Start Menu\Programs\Administrative Tools
CSIDL_ADMINTOOLS = &H30& '// <user name>\Start Menu\Programs\Administrative Tools
CSIDL_CONNECTIONS = &H31& '// Network and Dial-up Connections
CSIDL_COMMON_MUSIC = &H35& '// All Users\My Music
CSIDL_COMMON_PICTURES = &H36& '// All Users\My Pictures
CSIDL_COMMON_VIDEO = &H37& '// All Users\My Video
CSIDL_RESOURCES = &H38& '// Resource Direcotry
CSIDL_RESOURCES_LOCALIZED = &H39& '// Localized Resource Direcotry
CSIDL_COMMON_OEM_LINKS = &H3A& '// Links to All Users OEM specific apps
CSIDL_CDBURN_AREA = &H3B& '// USERPROFILE\Local Settings\Application Data\Microsoft\CD Burning
End Enum
'ﾌﾟﾛﾊﾟﾃｨ値を保持するためのﾛｰｶﾙ変数。
Private mobjOwner As Object 'ﾛｰｶﾙ ｺﾋﾟｰ
Private menmRootFolder As gEnumCSIDL 'ﾛｰｶﾙ ｺﾋﾟｰ
Private mstrTitle As String 'ﾛｰｶﾙ ｺﾋﾟｰ
Private menmFlags As gEnumBrowseInfoFlag 'ﾛｰｶﾙ ｺﾋﾟｰ
Private mstrInitDir As String 'ﾛｰｶﾙ ｺﾋﾟｰ
Private mstrDisplayName As String * MAX_PATH
'******************************************************************
'プロパティ名: :Let InitDir
'説明: :初期ディレクトリを設定する
'引数: :pstrValue I 初期ディレクトリ
'******************************************************************
Public Property Let InitDir(pstrValue As String)
mstrInitDir = pstrValue
End Property
'******************************************************************
'プロパティ名: :Get InitDir
'説明: :初期ディレクトリを取得する
'戻り値 :String型
'******************************************************************
Public Property Get InitDir() As String
InitDir = mstrInitDir
End Property
'******************************************************************
'プロパティ名: :Let Flags
'説明: :フラグを設定する
'引数: :penmValue I gEnumBrowseInfoFlagをOrで組み合わせて指定
'******************************************************************
Public Property Let Flags(ByVal penmValue As gEnumBrowseInfoFlag)
menmFlags = penmValue
End Property
'******************************************************************
'プロパティ名: :Get Flags
'説明: :フラグを取得する
'戻り値 :gEnumBrowseInfoFlag型
'******************************************************************
Public Property Get Flags() As gEnumBrowseInfoFlag
Flags = menmFlags
End Property
'******************************************************************
'プロパティ名: :Let Title
'説明: :ダイアログのタイトルを設定する
'引数: :pstrValue I ダイアログのタイトル
'******************************************************************
Public Property Let Title(pstrValue As String)
mstrTitle = pstrValue
End Property
'******************************************************************
'プロパティ名: :Get Title
'説明: :ダイアログのタイトルを取得する
'戻り値 :String型
'******************************************************************
Public Property Get Title() As String
Title = mstrTitle
End Property
'******************************************************************
'プロパティ名: :Let RootFolder
'説明: :フォルダツリーのルートをどこにするかを指定する
'引数: :penmValue I gEnumCSIDLの中から指定する
'******************************************************************
Public Property Let RootFolder(ByVal penmValue As gEnumCSIDL)
menmRootFolder = penmValue
End Property
'******************************************************************
'プロパティ名: :Get RootFolder
'説明: :ルートフォルダを取得する
'戻り値 :gEnumCSIDL型
'******************************************************************
Public Property Get RootFolder() As gEnumCSIDL
RootFolder = menmRootFolder
End Property
'******************************************************************
'プロパティ名: :Set Owner
'説明: :オーナーとなるフォームを指定する
'引数: :pobjValue I オーナーフォーム
'******************************************************************
Public Property Set Owner(pobjValue As Object)
Set mobjOwner = pobjValue
End Property
'******************************************************************
'プロパティ名: :Get Owner
'説明: :オーナーフォームを取得する
'戻り値 :Object型
'******************************************************************
Public Property Get Owner() As Object
Set Owner = mobjOwner
End Property
'******************************************************************
'プロシージャ名: :Show
'説明: :フォルダ選択ダイアログを表示する
'戻り値 :String型
'******************************************************************
Public Function Show() As String
'============= Declare ==============
Dim udtBI As tagBROWSEINFO
Dim lngPIDL As Long
Dim strPath As String * MAX_PATH
'============= Initiarize ===========
On Error GoTo Show_E00
Show = ""
'============= Main =================
With udtBI
If mobjOwner Is Nothing Then
.hOwner = 0&
Else
.hOwner = mobjOwner.hWnd
End If
.pidlRoot = menmRootFolder
.pszDisplayName = StrPtr(mstrDisplayName)
.lpszTitle = mstrTitle
.ulFlags = menmFlags
.lpfn = ProcPtr(AddressOf BrowseCallbackProc)
.lParam = ObjPtr(Me)
End With
lngPIDL = SHBrowseForFolder(udtBI) ' ダイアログ表示
If lngPIDL Then
On Error GoTo Show_E10
If SHGetPathFromIDList(lngPIDL, ByVal strPath) Then
Show = Left(strPath, InStr(strPath, vbNullChar) - 1&)
End If
Call CoTaskMemFree(lngPIDL) ' パス格納のために確保されたメモリを開放
On Error GoTo Show_E00
End If
'============= Release ==============
Show_L00:
Exit Function
'============= Error ================
Show_E10:
Call CoTaskMemFree(lngPIDL) ' パス格納のために確保されたメモリを開放
Show_E00:
Call Err.Raise(vbObjectError Or Err.Number, mcstrMODULE_NAME & ".Show" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
End Function
'------------------------------------------------------------------
'プロシージャ名: :ProcPtr
'説明: :AddressOfのラッパ関数
'引数: :plngAddressOfFunc I コールバックプロシージャのアドレス
'戻り値 :Long型
'------------------------------------------------------------------
Private Function ProcPtr(ByVal plngAddressOfFunc As Long) As Long
ProcPtr = plngAddressOfFunc
End Function
'------------------------------------------------------------------
'プロシージャ名: :Class_Initialize
'説明: :
'------------------------------------------------------------------
Private Sub Class_Initialize()
Set mobjOwner = Nothing
menmRootFolder = CSIDL_DESKTOP
mstrTitle = ""
menmFlags = 0&
mstrInitDir = CurDir()
mstrDisplayName = String$(MAX_PATH, vbNullChar)
End Sub
'------------------------------------------------------------------
'プロシージャ名: :Class_Terminate
'説明: :
'------------------------------------------------------------------
Private Sub Class_Terminate()
End Sub
コールバック関数のために、どうしたって標準モジュールが必要になります。
Attribute VB_Name = "MBrowseFolder"
Option Explicit
Private Const mcstrMODULE_NAME As String = "MBrowseFolder"
Private Const WM_USER As Long = &H400&
Private Const BFFM_INITIALIZED As Long = 1&
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100&)
Private Const BFFM_ENABLEOK As Long = (WM_USER + 101&)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102&)
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any _
) As Long
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER As Long = &H100&
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200&
Private Const FORMAT_MESSAGE_FROM_STRING As Long = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE As Long = &H800&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY As Long = &H2000&
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF&
Private Declare Function FormatMessage Lib "KERNEL32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, lpBuffer As Any, ByVal nSize As Long, Arguments As Long) As Long
'******************************************************************
'プロシージャ名: :BrowseCallbackProc
'説明: :フォルダ選択ダイアログのコールバック関数
'引数: :hwnd I フォルダ選択ダイアログのウィンドウハンドル
' :uMsg I メッセージの種類
' :lParam I
' :lpData I BROWSEINFO構造体に与えたlParam
'戻り値 :Long型
'******************************************************************
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As CBrowseFolder) As Long
'============= Declare ==============
Dim strData As String
'============= Initiarize ===========
On Error GoTo BrowseCallbackProc_E00
'============= Main =================
Select Case uMsg
Case BFFM_INITIALIZED
strData = lpData.InitDir
Call SendMessage(hWnd, BFFM_SETSELECTIONA, 1, ByVal strData)
Case Else
End Select
'============= Release ==============
BrowseCallbackProc_L00:
Exit Function
'============= Error ================
BrowseCallbackProc_E00:
Call Err.Raise(vbObjectError Or Err.Number, mcstrMODULE_NAME & ".BrowseCallbackProc" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)
End Function
'******************************************************************
'プロシージャ名: :pDllErrRaise
'説明: :Err.LastDllErrorよりエラーを発生する
'引数: :plngLastDllError I Err.LastDllError
' :pstrErrSource O エラーソース文字列
'******************************************************************
Public Sub DllErrRaise(ByVal plngLastDllError As Long, pstrErrSource As String)
'============= Declare ==============
Const clngMAX_BUFFER As Long = 1024&
Dim bytBuf(clngMAX_BUFFER - 1&) As Byte 'バッファ
Dim lngRet As Long 'APIの戻り値
Dim strErrDescription As String
'============= Initiarize ===========
If plngLastDllError = 0& Then
Exit Sub
End If
Erase bytBuf
strErrDescription = ""
'============= Main =================
'@@ ｴﾗｰ値に対応するメッセージを取得する
lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
ByVal 0&, _
plngLastDllError, _
0&, _
bytBuf(0), _
clngMAX_BUFFER, _
ByVal 0&)
If lngRet Then
strErrDescription = StrConv(LeftB(bytBuf, lngRet), vbUnicode)
End If
'@@ ｴﾗｰを発生する
Call Err.Raise(plngLastDllError Or vbObjectError, pstrErrSource, strErrDescription)
End Sub
------------------------
友人より、OleInitialize 呼んどけって書いてあるよ、という指摘を受けましたが、OleInitialize って、VB アプリであれば、最初に呼ばれてるからOKという認識でいたのですが、どうなんでしょう。
トラックバック
- このエントリーにトラックバック:
- http://frog.raindrop.jp/cgi-bin/mt/mt-tb.cgi/291
コメント
VBでフォルダ選択の実装方法を探していてここに来ました。
よそにもたくさん例があったのですが、クラス化されていて使いやすいので参考にさせていただきます。
プロの方なのでしょうか？？？
kiraさん、いらっしゃいませ。
> プロの方なのでしょうか？？？
プログラミングやシステム設計で飯を食ってるので、一応プロの方です 笑。