選択したディレクトリのフルパスを表示する

フォルダの選択ダイアログを表示するコード で、デフォルトのフォルダ選択をするためにコールバックを使うのですが、 そこにコードをちょこっと足すといろんな事ができそうです。

古いタイプのファイルの選択ダイアログで、選択中のディレクトリのフルパスが表示されたりしていたが、そういったことができないだろうかと思って実験してみた。

コールバックでBFFM_SELCHANGEDメッセージは、ツリービューのアイテムが選択されるたびにコールバックされるメッセージであるので、ここでパスを解析し、表示すればいい。

表示するため、SHBrowseForFolderのBROWSEINFO構造体のulFlagsにBIF_STATUSTEXTフラグをセットする。

流れとしては、

        Case BFFM_SELCHANGED
            strBuffer = String(MAX_PATH + 1, vbNullChar)
            ' 現在選択されているフォルダのパスを得る。
            lngResult = SHGetPathFromIDList(lParam, strBuffer)
            ' 成功した場合。
            If lngResult <> 0 Then
                ' バッファから有効な文字列を取り出す。
                strDir = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
                ' テキストをセットする。
                Call SendMessage(hwnd, _
                                 BFFM_SETSTATUSTEXTA, _
                                 0, _
                                 ByVal strDir)
            Else
                ' テキストを削除する。
                Call SendMessage(hwnd, _
                                 BFFM_SETSTATUSTEXTA, _
                                 0, _
                                 ByVal 0&)
            End If

しかし、上記のコードだけでは、フルパスが長い場合うまく表示しきれない。やはり「...」などのようにパスの一部を省略させて表示させたい。

そういった希望をかなえるAPIとしては、PathCompactPathがある。残念ながら、SHLWAPI.DLLに実装されているので、IEが古いバージョンの場合APIが無いかもしれない。しかし、今更IE4未満の環境のことなど考慮に入れる必要なんて無いだろう。 (^_^;) 

                    Call PathCompactPath(lngDCHandle, strDir, mlngStaticWidth)

さて、PathCompactPathには、引数としてhDC(デバイスコンテキストハンドル)が必要だ。これは、GetDCで得ることにする。お約束として使用後にはReleaseDCでハンドルを開放する必要がある。

もうひとつの引数に、ラベルの幅を得る必要がある。BFFM_INITIALIZEDメッセージのときに、 

            lngStaticHandle = FindWindowEx(hwnd, 0, "static", vbNullString)
            If lngStaticHandle <> 0 Then
                Call GetWindowRect(lngStaticHandle, rc)
                mlngStaticWidth = rc.Right - rc.Left
            End If

とすれば、モジュール変数mlngStaticWidthに幅が入る。ダイアログには、クラス名「static」は２つ存在するのだが、どちらも同じ幅のようなので気にしない気にしない。 (^_^;)

そういった訳で、全体のコードは以下のようになった。

Attribute VB_Name = "BrowseForFolders"
' =====================================
' BrowseForFolders(BFolder.Bas)
'                       Niiyama(HEROPA)
'                      heropa@dream.com
' =====================================
Option Explicit

' BROWSEINFO構造体
Private Type tagBROWSEINFO
    hOwner          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

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, _
                                 ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
                                (ByVal pv 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 Const MAX_PATH = 260
Private Const WM_USER = &H400

Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2

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 LocalAlloc Lib "kernel32" _
                                (ByVal uFlags As Long, _
                                 ByVal uBytes As Long) As Long

Private Declare Function LocalFree Lib "kernel32" _
                                (ByVal hMem As Long) As Long

Private Const LMEM_FIXED = &H0
Private Const LMEM_ZEROINIT = &H40
Private Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)


Public Enum BrowseInfoFlags
    ' ディレクトリ以外は選択できないようにする。
    ' ディレクトリではないフォルダを選択しても、
    ' OKボタンが有効にならない。
    BIF_RETURNONLYFSDIRS = &H1
    ' ネットワークドライブの選択はできないようにする。
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    ' エディットボックスを表示する。
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    ' コンピュータの選択しかできないようにする。
    BIF_BROWSEFORCOMPUTER = &H1000
    ' プリンタの選択しかできないようにする。
    BIF_BROWSEFORPRINTER = &H2000
    ' ファイルも選択できるようにする。
    BIF_BROWSEINCLUDEFILES = &H4000
End Enum

' --------追加--------
Private Type tagRECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
                                (ByVal hwndParent As Long, _
                                 ByVal hwndChildAfter As Long, _
                                 ByVal lpszClass As String, _
                                 ByVal lpszWindow As String) As Long

Private Declare Function GetWindowRect Lib "user32" _
                                (ByVal hwnd As Long, _
                                 lpRect As tagRECT) As Long

Private Declare Function GetDC Lib "user32" _
                                (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
                                (ByVal hwnd As Long, _
                                 ByVal hdc As Long) As Long

Private Declare Function PathCompactPath Lib "SHLWAPI.DLL" Alias "PathCompactPathA" _
                                (ByVal hdc As Long, _
                                 ByVal lpszPath As String, _
                                 ByVal dx As Long) As Long

Private mlngStaticWidth As Long
' --------------------
Private mstrDefaultPath As String
'
' コールバックされたメッセージによってメッセージを送る。
'
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
' --------追加--------
    Dim strBuffer       As String
    Dim lngResult       As Long
    Dim strDir          As String
    Dim lngStaticHandle As Long
    Dim rc              As tagRECT
    Dim lngDCHandle     As Long
' --------------------
    Select Case uMsg
        Case BFFM_INITIALIZED
            ' 選択されるフォルダを設定する。
            Call SendMessage(hwnd, _
                             BFFM_SETSELECTIONA, _
                             1, _
                             ByVal mstrDefaultPath)
' --------追加--------
            lngStaticHandle = FindWindowEx(hwnd, 0, "static", vbNullString)
            If lngStaticHandle <> 0 Then
                Call GetWindowRect(lngStaticHandle, rc)
                mlngStaticWidth = rc.Right - rc.Left
            End If
        Case BFFM_SELCHANGED
            strBuffer = String(MAX_PATH + 1, vbNullChar)
            ' 現在選択されているフォルダのパスを得る。
            lngResult = SHGetPathFromIDList(lParam, strBuffer)
            ' 成功した場合。
            If lngResult <> 0 Then
                ' バッファから有効な文字列を取り出す。
                strDir = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
                If mlngStaticWidth > 0 Then
                    strDir = Left$(strDir & String(MAX_PATH, vbNullChar), MAX_PATH)
                    lngDCHandle = GetDC(hwnd)
                    ' パスを表示しきれない場合は...で省略する。
                    Call PathCompactPath(lngDCHandle, strDir, mlngStaticWidth)
                    Call ReleaseDC(hwnd, lngDCHandle)
                    If InStr(strDir, vbNullChar) > 0 Then
                        strDir = Left$(strDir, InStr(strDir, vbNullChar) - 1)
                    End If
                End If
                ' テキストをセットする。
                Call SendMessage(hwnd, _
                                 BFFM_SETSTATUSTEXTA, _
                                 0, _
                                 ByVal strDir)
            Else
                ' テキストを削除する。
                Call SendMessage(hwnd, _
                                 BFFM_SETSTATUSTEXTA, _
                                 0, _
                                 ByVal 0&)
            End If
' --------------------
        Case Else
    End Select
End Function
'
'
'
Private Function FARPROC(pfn As Long) As Long
    ' AddressOfは標準モジュールのプロシージャを指定しなければならないので、
    ' ダミーのプロシージャを実装する。
    FARPROC = pfn
End Function
'
' フォルダの選択ダイアログを表示する。
'
Public Function ShowFolderDlg(ByVal hOwner As Long, ByVal strPrompt As String, ByVal strDefaultPath As String, ByVal lngFlag As BrowseInfoFlags) As String
' 【引数】
'   hOwner          : オーナーとなるウィンドウハンドル
'   strPrompt       : ダイアログ内に表示される文字列
'   strDefaultPath  : デフォルトとなるフルパス
'   lngFlag         : BROWSEINFO構造体のulFlag

    Dim bi        As tagBROWSEINFO
    Dim pidl      As Long
    Dim lpSelPath As Long
    Dim sPath     As String * MAX_PATH

    mstrDefaultPath = strDefaultPath
    With bi
        .hOwner = hOwner
        ' ここの値を0じゃなく、ちゃんとしたpidlを入れると
        ' ルートとなるフォルダを変更することができる。
        ' デフォルトの0というのはデスクトップ。
        .pidlRoot = 0
        ' ダイアログに表示するプロンプトをセットする。
        .lpszTitle = strPrompt
        ' フラグ値をセットする。
        .ulFlags = lngFlag
        ' コールバックに使用するメソッドをセットする。
        .lpfn = FARPROC(AddressOf BrowseCallbackProc)
    End With
    ' ダイアログを表示する。
    pidl = SHBrowseForFolder(bi)

    If pidl Then
        ' pidlからパス名に変換する。
        If SHGetPathFromIDList(pidl, sPath) Then
            ' パス名を取り出す。
            ShowFolderDlg = Left$(sPath, InStr(sPath, vbNullChar) - 1)
        End If
        ' pidlをメモリから開放する。
        Call CoTaskMemFree(pidl)
    End If
    ' 文字列のポインタを開放する。
    Call LocalFree(lpSelPath)
End Function

として、

Private Sub Command1_Click()
    Dim strPath         As String

    strPath = ShowFolderDlg(Me.hWnd, "フォルダを選択してちょんまげ", App.Path, BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT)
    If Len(strPath) > 0 Then
        Label1.Caption = "Path : " & strPath
    Else
        Label1.Caption = "キャンセルされた。"
    End If
End Sub
BackHome