フォルダダイアログの初期位置について (ID:82677)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文 これでどうですか？ <フォーム> コマンドボタンをひとつ貼り付ける Option Explicit Private Sub Command1_Click() MsgBox GetFolderDialog(Me.hwnd, CSIDL_DRIVES, "C:\Program Files", "フォルダ選択してください", BIF_SHOW) End Sub <標準モジュール> Option Explicit Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 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 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 Public Const CSIDL_DESKTOP = &H0 '[デスクトップ] Public Const CSIDL_INTER_EXP = &H1 '[InterNet Explorer] Public Const CSIDL_PROGRAMS = &H2 '[プログラム] Public Const CSIDL_CONTROLS = &H3 '[コントロールパネル] Public Const CSIDL_PRINTERS = &H4 '[プリンタ] Public Const CSIDL_PERSONAL = &H5 '[My Documents] Public Const CSIDL_FAVORITES = &H6 '[お気に入り] Public Const CSIDL_STARTUP = &H7 '[スタートアップ] Public Const CSIDL_RECENT = &H8 '[Recent] Public Const CSIDL_SENDTO = &H9 '[SendTo] Public Const CSIDL_BITBUCKET = &HA '[ごみ箱] Public Const CSIDL_STARTMENU = &HB '[スタートメニュー] Public Const CSIDL_DESKTOPDIRECTORY = &H10 '[デスクトップ(フォルダ)] Public Const CSIDL_DRIVES = &H11 '[マイコンピュータ] Public Const CSIDL_NETWORK = &H12 '[ネットワークコンピュータ] Public Const CSIDL_NETHOO = &H13 '[NetHood] Public Const CSIDL_FONTS = &H14 '[Fonts] Public Const CSIDL_TEMPLATES = &H15 '[ShellNew] Public Const BIF_CLOSE = &H1 '特殊フォルダは表示しない Public Const BIF_SHOW = &H2 '特殊フォルダも表示する Public Const BIF_FILES = &H4000 'ファイルも表示する Private Const WM_USER = &H400 Private Const BFFM_INITIALIZED = 1 Private Const BFFM_SETSELECTIONA = (WM_USER + 102) Private Function GetPointer(lngAddressOf As Long) As Long 'コールバック関数のアドレスを返す GetPointer = lngAddressOf End Function Private Function BFFCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long 'フォルダを指定のメッセージをダイアログへ送信 If uMsg = BFFM_INITIALIZED Then Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData) End If End Function '************************************************** '* 関数名 : GetFolderDialog '* 機 能 : 「フォルダ選択」ダイアログを表示する '* 引 数 : lngHwnd ウインドウのハンドル '* lngRoot ルートディレクトリ '* strTitle ダイアログタイトル '* strIniPath 初期パス '* lngFlag フラグ '* 戻り値 : フォルダ名 '************************************************** Public Function GetFolderDialog(ByVal lngHwnd As Long, ByVal lngRoot As Long, ByVal strIniPath As String, _ ByVal strTitle As String, ByVal lngFlg As Long) As String On Error GoTo ErrTrap Dim BI As BROWSEINFO 'BROWSEINFO構造体 Dim strPath As String 'パス Dim lngRet As Long '戻り値 With BI .hwndOwner = lngHwnd .lpszTitle = strTitle .pidlRoot = lngRoot .ulFlags = lngFlg .lpfn = GetPointer(AddressOf BFFCallback) .lParam = StrPtr(StrConv(strIniPath, vbFromUnicode) & vbNullChar) End With 'フォルダを開くダイアログを表示 lngRet = SHBrowseForFolder(BI) 'バッファを確保 strPath = String$(256, Chr$(0)) If lngRet <> 0 Then 'パスを取得 Call SHGetPathFromIDList(lngRet, strPath) 'パスを格納 GetFolderDialog = Left$(strPath, InStr(strPath, Chr$(0)) - 1) Else 'キャンセル GetFolderDialog = "" End If Exit Function ErrTrap: GetFolderDialog = "" End Function