HOME > エクセルVBA > サンプル > FolderBrowserDialog

FolderBrowserDialog


【ファイル名】FolderBrowserDialog.xlsm
【バージョン】Ver 1.0.0.5
【作成日】2019年04月09日
【更新日】2021年04月28日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】FolderBrowserDialog.zip
【説明】Windows APIによる「フォルダの参照」のダイアログのサンプルです。
メニュー

「フォルダの参照」のダイアログ
「フォルダの参照」のダイアログ

下記のマイクロソフトのサイトを参照しました。
【外部リンク】SHBrowseForFolderWSHGetPathFromIDListWCoTaskMemFreeBROWSEINFOW

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="SAM">
        <group id="Group1" label="フォルダの参照ダイアログ">
          <box id="Box1" boxStyle="horizontal">
 <!-- ■■■ ルート フォルダ -->
            <menu id="RootFolderMenu" label="ルート フォルダ(&R)" itemSize="normal" imageMso="Folder" size="normal" keytip="R">
              <button id="PROGRAMSButton" label="プログラム(&P)" supertip="プログラムをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="PERSONALButton" label="ドキュメント(&D)" supertip="ドキュメントをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="FAVORITESButton" label="お気に入り(&F)" supertip="お気に入りをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="STARTUPButton" label="スタートアップ(&S)" supertip="スタートアップをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="RECENTButton" label="最近使った項目(&R)" supertip="最近使った項目をルートで表示し、選択したファイルのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="SENDTOButton" label="送る(&S)" supertip="SendToをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="STARTMENUButton" label="スタートメニュー(&M)" supertip="スタートメニューをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="DRIVESButton" label="コンピュータ(&C)" supertip="PCをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="NETHOOButton" label="NetHood(&H)" supertip="Network Shortcutsをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="FontsButton" label="フォント(&F)" supertip="Fontsをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
              <button id="TEMPLATESButton" label="テンプレート(&T)" supertip="TEMPLATESをルートで表示し、選択したフォルダのパス名をアクティブ セルに代入します。" onAction="onAction" />
            </menu>
 <!-- ■■■ その他 -->
            <menu id="OtherMenu" label="その他(&O)" itemSize="normal" imageMso="Folder" size="normal" keytip="O">
              <button id="FolderName_or_FileNameButton" label="ファイルまたはフォルダーの参照(&F)" supertip="ファイルかあるいはフォルダを選択できます。" onAction="onAction" />
              <button id="EditBoxButton" label="EditBoxを表示(&E)" supertip="選択したフォルダの名前をEditBoxに表示します。" onAction="onAction" />
              <button id="IconIndexButton" label="アイコンのインデックスを表示(&I)" supertip="選択したフォルダのアイコンのインデックスを表示します。(シェルアイコンの番号とは違います)" onAction="onAction" />
            </menu>
          </box>
          <editBox id="editBox1" label="メッセージ:" keytip="M" supertip="ダイアログの上の方に表示するラベルの文字列を入力してください。"
                   maxLength="80" sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

clsFolderBrowserDialog
プロパティ
SelectedPath・・・ダイアログで選択したフォルダのパス名です。(読み取り専用)
IconIndex・・・ダイアログで選択したフォルダの画像の番号ですが、ImageRes.dllファイルとは違います。(読み取り専用)
RootFolder・・・ダイアログのルートフォルダです。ルートの親のフォルダは選択できません。
Message・・・ダイアログの上の方に表示されるラベルの文字列です。
Flags・・・ダイアログのオプション(BROWSEINFO_Flags)です。複数ある場合は、or を使用します。

メソッド
Show・・・フォルダの参照ダイアログを表示し、フォルダ名を取得します。「OK」ボタンを押すとTrueを返します。
Option Explicit

#If Win64 Then ' Office 64 bit の場合は
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/shlobj_core/nf-shlobj_core-shbrowseforfolderw
  Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderW" (lpBROWSEINFO As BROWSEINFOW) As LongPtr
  ' https://docs.microsoft.com/en-us/windows/desktop/api/shlobj_core/nf-shlobj_core-shgetpathfromidlistw
  Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListW" (ByVal pidl As LongPtr, ByVal pszPath As LongPtr) As Long
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/combaseapi/nf-combaseapi-cotaskmemfree
  Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)
  
  Private Type BROWSEINFOW ' https://docs.microsoft.com/en-us/windows/win32/api/shlobj_core/ns-shlobj_core-browseinfow
    hOwner As LongPtr ' ウィンドウのハンドル
    pidlRoot As LongPtr ' フォルダのルート
    pszDisplayName As LongPtr ' 選択されたフォルダ名(フルパス名ではありません)■ このサンプルでは使用しません。
    lpszTitle As LongPtr ' ダイアログに表示するラベルの文字列
    ulFlags As Long ' ダイアログのオプション
    lpfn As LongPtr ' コールバック関数のアドレス        ■ このサンプルでは使用しません。
    lParam As LongPtr ' コールバック関数の引数の値       ■ このサンプルでは使用しません。
    iImage As Long ' 選択したフォルダのアイコンのインデックス(シェルアイコンの番号とは違います)
  End Type
#Else
  Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderW" (lpBROWSEINFO As BROWSEINFOW) As Long
  Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListW" (ByVal pidl As Long, ByVal pszPath As Long) As Long
  Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
  
  Private Type BROWSEINFOW
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
  End Type
#End If

Private Const MAX_PATH = 260 ' パスの文字列の最大数

Public Enum BROWSEINFO_Flags
  Default = &H0&                 ' フォルダを選択する(既定)
  RETURNONLYFSDIRS = &H1&        ' ファイルシステム ディレクトリの選択のみ可能(仮想フォルダは不可)
  DONTGOBELOWDOMAIN = &H2&       ' ドメインのネットワーク フォルダを含まない
  STATUSTEXT = &H4&              ' ステータス表示領域を追加する(コールバック関数で使用する)
  RETURNFSANCESTORS = &H8&       ' ルート以下のみを選択可能にする
  EditBox = &H10&                ' テキスト ボックスを追加する
  Validate = &H20&               ' 無効なパス名が入力されたときに、BroeseCallbackProcコールバック関数を呼び出す
  BROWSEFORCOMPUTER = &H1000&    ' コンピュータ フォルダのみ選択可能
  BROWSEFORPRINTER = &H2000&     ' プリンタ フォルダのみ選択可能
  BROWSEINCLUDEFILES = &H4000&   ' ファイルも表示する
End Enum

Public Enum myRootFolder ' ルートで表示するフォルダ
  Default = &H0&  ' PC(既定)
  PROGRAMS = &H2& ' プログラム
''  Controls = &H3& ' コントロール パネル
''  PRINTERS = &H4& ' プリンタ
  PERSONAL = &H5& ' ドキュメント
  FAVORITES = &H6& ' お気に入り
  STARTUP = &H7& ' スタートアップ
  RECENT = &H8& ' 最近使ったファイル
  SENDTO = &H9& ' 送る
''  BITBUCKET = &HA& ' ごみ箱
  STARTMENU = &HB& ' スタートメニュー
  DESKTOPDIRECTORY = &H10& ' デスクトップ
  DRIVES = &H11& ' コンピュータ
''  NETWORK = &H12& ' ネットワーク
  NETHOO = &H13& ' NetHood
  Fonts = &H14& ' フォント
  TEMPLATES = &H15& ' テンプレート
End Enum '' 【注意】選択できないフォルダはコメントにしました。

Private m_SelectedPath As String ' 選択したフォルダ名 【注意】ダイアログを表示する前にフォルダは変更できません。
Private m_Message As String ' ダイアログの上の方に表示するラベルの文字列です。
Private m_pidlRoot As myRootFolder ' ルートで表示するフォルダ。このフォルダの親には移動できません。
Private m_Flags As Long ' ダイアログのオプション(BROWSEINFO_Flags) 複数ある場合は、or を使用します。
Private m_IconIndex As Long ' 選択したフォルダのアイコンのインデックス(ImageRes.dllのアイコンの番号と違います)

Public Property Get SelectedPath() As String ' 選択したフォルダのパス名(読み取り専用)
  SelectedPath = m_SelectedPath
End Property

Public Property Get Message() As String ' フォルダのダイアログの上の方に表示されるラベルの文字列
  Message = m_Message
End Property
Public Property Let Message(NewValue As String)
  m_Message = NewValue
End Property

Public Property Get RootFolder() As myRootFolder ' ダイアログのルートフォルダ
  RootFolder = m_pidlRoot
End Property
Public Property Let RootFolder(NewValue As myRootFolder)
  m_pidlRoot = NewValue
End Property

Public Property Get Flags() As Long ' フォルダ ダイアログのオプション(BROWSEINFO_Flags) 複数ある場合は、or を使用する
  Flags = m_Flags
End Property
Public Property Let Flags(NewValue As Long)
  m_Flags = NewValue
End Property

Public Property Get IconIndex() As String ' 選択したフォルダのシェルアイコンのインデックス(読み取り専用)
  IconIndex = m_IconIndex
End Property
'--------------------------------------------------------------------------------------------
Public Function Show() As Boolean ' フォルダの参照ダイアログを表示し、フォルダ名を取得します。
  Dim pBROWSEINFO As BROWSEINFOW ' フォルダの参照ダイアログの設定
  Dim pPath As String ' パス名
  Dim pTitle As String ' ラベルの文字列
  
  Dim pszDisplayName  As String ' 選択されたフォルダ名
#If Win64 Then ' Office 64 bit の場合は
  Dim pidList As LongPtr
#Else
  Dim pidList As Long
#End If
  
  With pBROWSEINFO
    .hOwner = 0& ' ウィンドウのハンドル Application.Hwnd でも良いです。
    #If Win64 Then ' Office 64 bit の場合は
      .pidlRoot = CLngPtr(m_pidlRoot) ' ルートで表示するフォルダ
    #Else
      .pidlRoot = CLng(m_pidlRoot) ' ルートで表示するフォルダ
    #End If
    pszDisplayName = String(MAX_PATH, vbNullChar) ' 選択されたフォルダ名
    .pszDisplayName = StrPtr(pszDisplayName)
    pTitle = Message + vbNullChar ' ラベルの文字列
    .lpszTitle = StrPtr(pTitle)
    .ulFlags = Flags ' フォルダ ダイアロのグオプション
    .lpfn = 0 ' コールバック関数のアドレス
    .lParam = 0 ' コールバック関数の引数の値
    .iImage = 0 ' 選択したフォルダのアイコンのインデックス
  End With
  
  pidList = SHBrowseForFolder(pBROWSEINFO) ' フォルダの参照ダイアログを表示する
  pPath = String(MAX_PATH, vbNullChar)
  Show = SHGetPathFromIDList(pidList, StrPtr(pPath)) <> 0 ' パス名の文字列を取得する
  
  If Show Then ' [OK]ボタンを押した場合は、
    m_SelectedPath = Left(pPath, InStr(pPath, vbNullChar) - 1) ' Windows APIからVBAの文字列に変換
    m_IconIndex = pBROWSEINFO.iImage ' アイコンのインデックス
  Else
    m_SelectedPath = "" ' [キャンセル]ボタンを押した場合。
  End If
  CoTaskMemFree pidList ' メモリの解放
End Function

Private Sub Class_Initialize() ' 初期処理
  RootFolder = myRootFolder.Default ' ルートで表示するフォルダ
  Flags = BROWSEINFO_Flags.Default ' フォルダ ダイアロのグオプション
  Message = vbNullString ' ラベルの文字列
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン
Private rbText As String ' editBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbText = ""
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  Dim FolderBrowserDialog As clsFolderBrowserDialog
  
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Set FolderBrowserDialog = New clsFolderBrowserDialog
  FolderBrowserDialog.RootFolder = myRootFolder.Default ' ルートのフォルダを指定する
  FolderBrowserDialog.Flags = BROWSEINFO_Flags.Default ' フォルダの選択
  FolderBrowserDialog.Message = rbText ' 上の方に表示するラベルの文字列
  
  Select Case control.ID
'---< フォルダを選択 >--------------------------------------------------------------------------------------------------------
''    Case "DESKTOPButton"
''      FolderBrowserDialog.RootFolder = DESKTOP
    Case "PROGRAMSButton" ' プログラム
      FolderBrowserDialog.RootFolder = PROGRAMS
''    Case "ControlsButton"
''      FolderBrowserDialog.RootFolder = Controls
''    Case "PRINTERSButton"
''      FolderBrowserDialog.RootFolder = PRINTERS
    Case "PERSONALButton" ' ドキュメント
      FolderBrowserDialog.RootFolder = PERSONAL
    Case "FAVORITESButton" ' お気に入り
      FolderBrowserDialog.RootFolder = FAVORITES
    Case "STARTUPButton" ' スタートアップ
      FolderBrowserDialog.RootFolder = STARTUP
    Case "RECENTButton" ' 最近使ったファイル
      FolderBrowserDialog.RootFolder = RECENT
    Case "SENDTOButton" ' 送る
      FolderBrowserDialog.RootFolder = SENDTO
''    Case "BITBUCKETButton"
''      FolderBrowserDialog.RootFolder = BITBUCKET
    Case "STARTMENUButton" ' スタートメニュー
      FolderBrowserDialog.RootFolder = STARTMENU
    Case "DESKTOPDIRECTORYButton" ' デスクトップ
      FolderBrowserDialog.RootFolder = DESKTOPDIRECTORY
    Case "DRIVESButton" ' コンピュータ
      FolderBrowserDialog.RootFolder = DRIVES
''    Case "NETWORKButton"
''      FolderBrowserDialog.RootFolder = NETWORK
    Case "NETHOOButton" ' NetHood
      FolderBrowserDialog.RootFolder = NETHOO
    Case "FontsButton" ' フォント
      FolderBrowserDialog.RootFolder = Fonts
    Case "TEMPLATESButton" ' テンプレート
      FolderBrowserDialog.RootFolder = TEMPLATES
'---< その他 >----------------------------------------------------------------------------------------------------------------
    Case "FolderName_or_FileNameButton" ' ファイルまたはフォルダーの参照
      FolderBrowserDialog.Flags = BROWSEINCLUDEFILES
      FolderBrowserDialog.Message = "ファイルかあるいはフォルダを選択してください。"
    Case "EditBoxButton" ' EditBoxを表示
      FolderBrowserDialog.Flags = EditBox
    Case "IconIndexButton" ' アイコンのインデックス
    '
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical, Title:="エラー"
      Exit Sub
  End Select
  
  If FolderBrowserDialog.Show Then ' フォルダ ダイアログを表示する
    If control.ID = "IconIndexButton" Then
      MsgBox "アイコンのインデックス:" & FolderBrowserDialog.IconIndex, vbInformation, "情報" '
    Else
      If ActiveCell Is Nothing Then
        MsgBox FolderBrowserDialog.SelectedPath, vbInformation, "情報" ' 選択したフォルダのパス名を表示します。
      Else
        ActiveCell.Value = FolderBrowserDialog.SelectedPath ' アクティブ セルに選択したパス名を代入する
      End If
    End If
  End If
  
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical, Title:="エラー"
End Sub

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  returnedVal = rbText
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  rbText = text
End Sub
このページの上

FunctionModule
Option Explicit

' フォルダのダイアログを表示してフォルダ名を取得します。キャンセルしたら空の文字列を返します。
' Application.FileDialog(msoFileDialogFolderPicker)
Public Function GetFolderDialog(Optional pInitialFileName As String = "", _
                              Optional pTitle As String = "ディレクトリの参照", _
                              Optional pButtonName As String = "参照(&B)", _
                              Optional pInitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String

  GetFolderDialog = ""
  
  With Application.FileDialog(msoFileDialogFolderPicker)
    If pInitialFileName = "" Then
      .InitialFileName = CurDir()
    Else
      .InitialFileName = pInitialFileName
    End If
    .Title = pTitle
    .ButtonName = pButtonName ' &の後の文字のアクセスキーは大文字のみ? 小文字は下線がついても実行できない?
    .InitialView = pInitialView ' 変更できない?
    If .Show = 0 Then Exit Function ' [キャンセル]ボタン
    GetFolderDialog = .SelectedItems(1)
  End With
End Function

Sub Test_GetFolderDialog()
  MsgBox GetFolderDialog("c:\", "ディレクトリの参照してください。", "選択(&S)", msoFileDialogViewSmallIcons)
End Sub

' フォルダのダイアログを表示してフォルダ名を取得します。キャンセルしたら空の文字列を返します。
' Shell32.Shell BrowseForFolder
Public Function GetBrowseForFolder(Optional Prompt As String = "フォルダを選択してください。", _
                                   Optional RootFolder As Shell32.ShellSpecialFolderConstants = ssfDESKTOP) As String
  Const BIF_EDITBOX As Long = &H10
' Shellの型を参照するには「ツール」の「参照設定」のメニューで、「Microsoft Shell Controls And Automation」をチェックし、「OK」ボタンを実行します。
' "C:\Windows\System32\shell32.dll"
' Shell.BrowseForFolder method
' https://docs.microsoft.com/ja-jp/windows/win32/shell/shell-browseforfolder
  Dim Shell ' As Shell32.Shell
  Dim Folder ' As Shell32.Folder3
  
  GetBrowseForFolder = ""
  Set Shell = CreateObject("Shell.Application")
  Set Folder = Shell.BrowseForFolder(0&, Prompt, BIF_EDITBOX, RootFolder)
  If Not Folder Is Nothing Then
    If Folder.Items.Item Is Nothing Then
      GetBrowseForFolder = Folder.Self.Path
    Else
      GetBrowseForFolder = Folder.Items.Item.Path
    End If
  End If
  
  Set Folder = Nothing
  Set Shell = Nothing
End Function

Sub Test_GetBrowseForFolder()
  MsgBox GetBrowseForFolder("ディレクトリを参照してください。", ssfHISTORY)
End Sub
このページの上
【外部リンク】Docs / Office VBA リファレンス / Excel / オブジェクト モデル / Application オブジェクト / プロパティ / FileDialog / Application.FileDialog property (Excel)
【外部リンク】Shell.BrowseForFolder method