vb6のフォルダ参照ダイアログの初期フォルダの指定方法

現在フォルダ参照ダイアログを導入しているのですが、初期フォルダの指定方法がわかりません。

インターネットで調べたところ、方法はあるということは理解できたのですが、どうすればできるかがわかりません。

現在のソースを大きく修正しなくて済む方法はないかと調べていましたがわかりません。

アドバイス、または参考サイトなど教えていただきたいです。

どうかよろしくお願いいたします。

ソースですが、

vb6
1'/* FolderBrowserDialog クラス モジュール */
2Option Explicit
3
4
5' SHBrowseForFolder 関数
6Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" ( _
7    ByRef lpBrowseInfo As TypeBrowseInfo _
8) As Long
9
10
11' SHGetPathFromIDList 関数
12Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias "SHGetPathFromIDListA" ( _
13    ByVal pidl    As Long,  _
14    ByVal pszPath As String _
15) As Long
16
17
18' CoTaskMemFree 関数
19Private Declare Sub CoTaskMemFree Lib "OLE32.DLL" (ByVal pv As Long)
20
21
22' BrowseInfo 構造体
23Private Type TypeBrowseInfo
24    OwnerHandle As Long
25    Root        As Long
26    DisplayName As String
27    Description As String
28    Flags       As BifOptions
29    lpfn        As Long
30    lParam      As String
31    iImage      As Long
32End Type
33
34
35' FolderBrowseDialog 設定用の列挙体
36Private Enum BifOptions
37    ReturnOnlyFileSystemDirectories = &H1     ' コントロールパネル・プリンタ・ブリーフケース内は選択不可
38    HideNetworkResource             = &H2     ' ネットワーク内のリソースを非表示
39    StatusText                      = &H4     ' テキスト文字列を表示 (設定は Callback 関数で行う)
40    OnlyNetworkResource             = &H8     ' ネットワーク内のリソースのみ選択可能
41    ShowEditBox                     = &H10    ' フォルダ名を編集する TextBox を表示
42    Validate                        = &H20    ' 検証を実行する
43    NewDialogStyle                  = &H40    ' 新しいフォルダの作成を表示 (Winodws 2000 以降から有効)
44    BrowseForComputer               = &H1000  ' ネットワークコンピュータ内のリソースのみ選択可
45    BrowseForPrinter                = &H2000  ' ネットワークプリンタのみ選択可
46    BrowseIncludeFiles              = &H4000  ' フォルダ内のファイル名も表示 (Windows 98 以降)
47End Enum
48
49
50' プロパティ 変数
51Private m_SelectedPath As String
52Private BrowseInfo     As TypeBrowseInfo
53
54
55' SelectedPath - Get
56Public Property Get SelectedPath() As String
57    SelectedPath = m_SelectedPath
58End Property
59
60
61' SelectedPath - Let
62Public Property Let SelectedPath(ByVal value As String)
63    m_SelectedPath = value
64End Property
65
66
67' Description - Get
68Public Property Get Description() As String
69    Description = BrowseInfo.Description
70End Property
71
72
73' Description - Let
74Public Property Let Description(ByVal value As String)
75    BrowseInfo.Description = value
76End Property
77
78
79' ShowNewFolderButton - Get
80Public Property Get ShowNewFolderButton() As Boolean
81    ShowNewFolderButton = ((BrowseInfo.Flags And NewDialogStyle) > 0)
82End Property
83
84
85' ShowNewFolderButton - Let
86Public Property Let ShowNewFolderButton(ByVal value As Boolean)
87    If value Then
88        BrowseInfo.Flags = BrowseInfo.Flags Or NewDialogStyle
89    Else
90        BrowseInfo.Flags = BrowseInfo.Flags And Not NewDialogStyle
91    End If
92End Property
93
94
95' コンストラクタ
96Private Sub Class_Initialize()
97    BrowseInfo.Flags = BrowseInfo.Flags Or NewDialogStyle
98End Sub
99
100
101'「フォルダの参照」ダイアログを表示する
102Public Function ShowDialog(Optional ByVal hOwnerHandle As Long = 0&) As Boolean
103    Dim lReturn As Long
104
105    ' 親ハンドルを設定する
106    BrowseInfo.OwnerHandle = hOwnerHandle
107
108    '「フォルダの参照」ダイアログを呼び出す
109    lReturn = SHBrowseForFolder(BrowseInfo)
110
111    ' OK が押下された場合
112    If lReturn <> 0 Then
113        Dim stPath As String
114
115        stPath = String$(65536, vbNullChar)
116
117        Call SHGetPathFromIDList(lReturn, stPath)
118        Call CoTaskMemFree(lReturn)
119
120        Me.SelectedPath = Left$(stPath, InStr(stPath, vbNullChar) - 1)
121        ShowDialog = True
122    End If
123End Function
124

呼び出し部が

vb6
1    ' FolderBrowserDialog クラスの新しいインスタンスを生成する
2    Dim cFolderBrowserDialog As FolderBrowserDialog
3    Set cFolderBrowserDialog = New FolderBrowserDialog
4
5    ' ダイアログの説明を設定する
6    cFolderBrowserDialog.Description = "ここに説明を書いてください"
7
8    ' [新しいフォルダ] ボタンを表示する (初期値 True)
9    'cFolderBrowserDialog.ShowNewFolderButton = True
10
11    ' ダイアログを表示し、戻り値が [OK] の場合は、選択したディレクトリを表示する
12    If cFolderBrowserDialog.ShowDialog(Me.hWnd) Then
13        Call MsgBox(cFolderBrowserDialog.SelectedPath)
14    End If
15
16    ' 不要になった時点で参照を解放する (Terminate イベントを早めに起こす)
17    Set cFolderBrowserDialog = Nothing

となっています。

環境
WindowsXP Professional
VB6.0(SP6)

行動規範の内容に同意します

回答1件

ベストアンサー

むかしむかし、あるしがないプログラマーが作成したものです。
参考になるでしょうか？

初期選択フォルダーの指定について処理を補足するとこんな感じです

SHBrowseForFolder()のパラメーターのBROWSEINFO.lpfn に callback function (ここではBrowseCallbackProc())を指定し、BROWSEINFO.lParam にBrowseCallbackProc()に渡すパラメーター(ここでは初期選択フォルダーのPATH)を設定します。
このBrowseCallbackProc()では、ファイル選択ダイアログの初期化時（BFFM_INITIALIZEDのとき）にCall SendMessageStr(lngHWnd, BFFM_SETSELECTIONA, 1&, StrConv(lngLpData, vbUnicode))としてlngLpData(初期選択フォルダーのPATH)を選択(BFFM_SETSELECTIONA)するWindowsメッセージを送信します。

VBScript
1' フォルダー選択ダイアログを表示
2'  *** この内容を標準モジュールに作成してください ***
3' strTitle    : ダイアログのタイトル
4' lngOwnerHwnd: 親ウィンドウのウィンドウハンドル
5' lngRoot     : ルートフォルダーの指定
6' lngFlags    : 表示形態の指定
7' strParam    : 初期状態選択フォルダー
8
9Option Explicit
10
11Private Const MAX_PATH            As Long = 260
12Private Const BFFM_SETSTATUSTEXTA As Long = &H464&  ' ステータステキスト
13Private Const BFFM_ENABLEOK       As Long = &H465&  ' OK ボタンの使用可否
14Private Const BFFM_SETSELECTIONA  As Long = &H466&  ' アイテムを選択
15Private Const BFFM_INITIALIZED    As Long = &H1&
16Private Const BFFM_SELCHANGED     As Long = &H2&
17Private Type RECT
18        left As Long    'WindowのX座標
19        top As Long     'WindowのY座標
20        right As Long   'Windowの右端の座標
21        bottom As Long  'Windowの底にあたる部分の座標
22End Type
23Private Type BROWSEINFO
24    hWndOwner       As Long     'ダイアログの親ウィンドウのハンドル
25    pidlRoot        As Long     'ディレクトリツリーのルート
26    pszDisplayName  As String   'MAX_PATH
27    lpszTitle       As String   'ダイアログの説明文
28    ulFlags         As Long     'ENUM_FLAGS_FOLDER
29    lpfn            As Long     'コールバック関数へのポインタ
30    lParam          As String   'コールバック関数へのパラメータ
31    iImage          As Long     'フォルダーアイコンのシステムイメージリスト
32End Type
33Public Enum ENUM_ROOT_FOLDER
34    CSIDL_DESKTOP = &H0&                        ' デスクトップ
35    CSIDL_INTERNET = &H1&                       ' インターネット
36    CSIDL_PROGRAMS = &H2&                       ' Program Files
37    CSIDL_CONTROLS = &H3&                       ' コントロールパネル
38    CSIDL_PRINTERS = &H4&                       ' プリンタ
39    CSIDL_PERSONAL = &H5&                       ' ドキュメントフォルダー
40    CSIDL_FAVORITES = &H6&                      ' お気に入り
41    CSIDL_STARTUP = &H7&                        ' スタートアップ
42    CSIDL_RECENT = &H8&                         ' 最近使ったファイル
43    CSIDL_SENDTO = &H9&                         ' 送る
44    CSIDL_BITBUCKET = &HA&                      ' ごみ箱
45    CSIDL_STARTMENU = &HB&                      ' スタートメニュー
46    CSIDL_DESKTOPDIRECTORY = &H10&              ' デスクトップフォルダー
47    CSIDL_DRIVES = &H11&                        ' マイコンピュータ
48    CSIDL_NETWORK = &H12&                       ' ネットワーク(ネットワーク全体あり)
49    CSIDL_NETHOOD = &H13&                       ' NETHOOD フォルダー
50    CSIDL_FONTS = &H14&                         ' フォント
51    CSIDL_TEMPLATES = &H15&                     ' テンプレート
52    CSIDL_COMMON_STARTMENU = &H16&              '
53    CSIDL_COMMON_PROGRAMS = &H17&               '
54    CSIDL_COMMON_STARTUP = &H18&                '
55    CSIDL_COMMON_DESKTOPDIRECTORY = &H19&       '
56    CSIDL_APPDATA = &H1A&                       '
57    CSIDL_PRINTHOOD = &H1B&                     '
58    CSIDL_ALTSTARTUP = &H1D&                    '
59    CSIDL_COMMON_ALTSTARTUP = &H1E&             '
60    CSIDL_COMMON_FAVORITES = &H1F&              '
61    CSIDL_INTERNET_CACHE = &H20&                '
62    CSIDL_COOKIES = &H21&                       '
63    CSIDL_HISTORY = &H22&                       '
64End Enum
65Enum ENUM_FLAGS_FOLDER
66    BIF_RETURNONLYFSDIRS = &H1&          ' フォルダのみ
67    BIF_DONTGOBELOWDOMAIN = &H2&         ' ネットワークコンピューターを非表示
68    BIF_STATUSTEXT = &H4&                ' ステータス表示
69    BIF_RETURNFSANCESTORS = &H8&
70    BIF_BROWSEFORCOMPUTER = &H1000&      ' ネットワークコンピューターのみ
71    BIF_BROWSEFORPRINTER = &H2000&       ' プリンターのみ
72    BIF_BROWSEINCLUDEFILES = &H4000&     ' 全て選択可能
73End Enum
74
75Private Declare Function SHBrowseForFolder Lib "shell32" (ByRef lpbi As BROWSEINFO) As Long
76Private Declare Function SHGetPathFromIDList Lib "shell32" _
77        (ByVal pidl As Long, ByVal pszPath As String) As Long
78Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
79        (ByVal hWnd As Long, ByVal wMsg As Long, _
80         ByVal wParam As Long, ByVal lParam As String) As Long
81Private Declare Function SHFree Lib "shell32" Alias "#195" (ByVal pidl As Long) As Long
82Private Declare Function GetDesktopWindow Lib "user32" () As Long
83
84'
85' フォルダー選択ダイアログを表示
86'   strTitle     : ダイアログに表示する説明文。
87'   lngOwnerHwnd : ダイアログのオーナーウィンドウ。
88'   lngRoot      : CSIDL_xxx の定数
89'   lngFlags     : BIF_xxx の定数
90'   strParam     : デフォルトのフォルダーPATH
91' 戻値  正常終了 - フォルダー名 / 異常終了 - ""
92'
93Public Function GetFolderName( _
94    Optional ByRef strTitle As String = "フォルダーを選択してください", _
95    Optional ByVal lngOwnerHwnd As Long = 0&, _
96    Optional ByVal lngRoot As ENUM_ROOT_FOLDER = CSIDL_DESKTOP, _
97    Optional ByVal lngFlags As ENUM_FLAGS_FOLDER = BIF_RETURNONLYFSDIRS, _
98    Optional ByRef strParam As String = vbNullString) As String
99
100    On Error GoTo Err_GetFolderName:
101
102    Dim biParam     As BROWSEINFO
103    Dim pidl        As Long
104    Dim strPath     As String
105
106    If lngOwnerHwnd = 0& Then
107        lngOwnerHwnd = GetDesktopWindow()
108    End If
109
110    strPath = String$(MAX_PATH, vbNullChar)
111
112    With biParam
113        .hWndOwner = lngOwnerHwnd
114        .pidlRoot = lngRoot
115        .pszDisplayName = strPath
116        .lpszTitle = strTitle & vbNullChar
117        .ulFlags = lngFlags
118        If Len(strParam) > 0& Then
119            
120            .lpfn = GetLong(AddressOf BrowseCallbackProc)
121            .lParam = strParam & vbNullChar
122        End If
123    End With
124
125    pidl = SHBrowseForFolder(biParam)
126
127    If biParam.ulFlags And BIF_BROWSEFORCOMPUTER Then
128        strPath = biParam.pszDisplayName
129        strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
130    Else
131        If pidl = 0& Then
132            strPath = vbNullString
133        Else
134            If SHGetPathFromIDList(pidl, strPath) <> 0& Then
135                strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
136            Else
137                strPath = vbNullString
138            End If
139        End If
140    End If
141
142    Call SHFree(pidl)
143    GetFolderName = strPath
144Exit_GetFolderName:
145    Exit Function
146
147Err_GetFolderName:
148    GetFolderName = vbNullString
149    Resume Exit_GetFolderName:
150End Function
151'
152'
153'   SHBrowseForFolder API のコールバック関数。
154'
155Private Function BrowseCallbackProc(ByVal lngHWnd As Long, ByVal lngUMsg As Long, _
156                            ByVal lngLParam As Long, ByVal lngLpData As String) As Long
157    Select Case lngUMsg
158        Case BFFM_INITIALIZED
159            Call SendMessageStr(lngHWnd, BFFM_SETSELECTIONA, 1&, StrConv(lngLpData, vbUnicode))
160        'Case BFFM_SELCHANGED
161        ' ITEMが選択された時に処理を行いたい場合ここに書きます
162    End Select
163    BrowseCallbackProc = 0&
164End Function
165
166Private Function GetLong(varAddr As Variant) As Long
167    GetLong = CLng(varAddr)
168End Function
169