#037 フォルダ参照ダイアログを使うには? VBA、API

フォルダ参照ダイアログのサンプル画面右図のような「フォルダの参照」ダイアログを表示しフォルダを選択するには、"SHELL32.DLL"にあるWindowsAPIの「SHBrowseForFolder」関数と「SHGetPathFromIDList」関数を使用します。

まず標準モジュールに次のコードを記述します。ここで、"Type"や"Declare"で始まる部分はお決まりの記述ですのでそのまま使って下さい。"Type"や"Declare"の前に"Private"を付けることによってフォームのモジュールにも記述できます。また、GetBrowseFolderプロシージャはオリジナルなものですので、WinodwAPI名などを除いたプロシージャ名や変数名などは書き換えても構いません。
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

Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "SHELL32" (ByVal pIDL As Long, ByVal pszPath As String) As Long

Public Function GetBrowseFolder(strMsg As String) As String
'このプロシージャはフォルダの参照ダイアログを表示し選択されたフォルダ名を返します。
'もしダイアログで[キャンセル]ボタンが押された場合は長さゼロ("")の文字列を返します。
'引数 strMsg にはダイアログに表示する、"フォルダを指定して下さい"のような文字列を指定します。
  Dim udtBrowseInfo As BROWSEINFO
  Const cMaxPathLen = 256
  Dim strBuffer As String * cMaxPathLen
  Dim strPathBuffer As String * cMaxPathLen
  Dim strRetPath As String
  Dim lngRet As Long
  
  With udtBrowseInfo
    .hWndOwner = Application.hWndAccessApp
    .pidlRoot = &H0
    .pszDisplayName = strBuffer
    .lpszTitle = strMsg & vbNullChar
    .ulFlags = 1&
    .lpfn = 0
    .lParam = 0
    .iImage = 0
  End With
  
  GetBrowseFolder = ""
  lngRet = SHBrowseForFolder(udtBrowseInfo)
  If lngRet <> 0 Then
    If SHGetPathFromIDList(lngRet, strPathBuffer) <> 0 Then
      GetBrowseFolder = Left(strPathBuffer, InStr(strPathBuffer, vbNullChar) - 1)
    End If
  End If

End Function

次のコードは、上記のプロシージャを使って実際にフォルダ参照ダイアログを表示し、そこで選択されたフォルダ名を使って以降の処理を行う例です。ここでは、フォームの"cmdOutputText"という名前のコマンドボタンをクリックすることによって、テキストファイルの出力先となるフォルダを選択するためのダイアログを表示させています。
Private Sub cmdOutputText_Click()
  
  Dim strFolder As String
  
  'フォルダの参照ダイアログを表示
  strFolder = GetBrowseFolder("テキストファイルを出力するフォルダを指定して下さい。")
  If Len(strFolder) > 0 Then
    'フォルダが選択されたとき
    Open strFolder & "\OUTPUT.TXT" For Output As #1
        ・・・・・・以降テキストファイルの書き出し処理・・・・・・
  Else
    'キャンセルされたとき
    Beep
  End If

End Sub
| Index | Prev | Next |

この情報は参考になりましたか?、問題は解決しましたか?、もしまだなら......
T'sWareのワンポイトテクニカルアドバイスをご利用ください。3000円/件〜でご支援します。
スタンドアロンからSQL Server対応まで、オーダーメイドのシステムを短納期・安価でお届けします
 

Copyright © T'sWare All rights reserved