C# と VB.NET の質問掲示板

'こちらが現在の状態のコードです
'実行は
'FolderDialogOpen_TEST()
'にて試せます。
'また初期パスはサンプルでは"C:\folder1\folder2"になっています。
'
'    FolderDialog_Path = "C:\folder1\folder2"	'フォルダ指定ダイアログ用初期パス
'    FolderDialog_UpPath = "C:\folder1"		'フォルダ指定ダイアログ用初期パス(一つ上)
'

Option Explicit

Private Const MAX_PATH                  As Long = 260
    
Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExW" ( _
    ByVal hWndParent As LongPtr, _
    ByVal hwndChildAfter As LongPtr, _
    ByVal lpszClass As LongPtr, _
    ByVal lpszWindow As LongPtr) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderW" ( _
    lpBrowseInfo As BROWSEINFO) As LongPtr

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListW" ( _
    ByVal pidl As LongPtr, _
    ByVal pszPath As LongPtr) As Long

Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" ( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    lParam As Any) As Long

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" ( _
    ByVal pv As LongPtr)

Public Type BROWSEINFO
    hWndOwner       As LongPtr
    pidlRoot        As Long
    pszDisplayName  As LongPtr
    lpszTitle       As LongPtr
    ulFlags         As Long
    lpfn            As LongPtr
    lParam          As LongPtr
    iImage          As Long
End Type

Private Const BIF_RETURNONLYFSDIRS      As Long = &H1&
Private Const BIF_NEWDIALOGSTYLE        As Long = &H40&
Private Const BIF_NONEWFOLDERBUTTON     As Long = &H200&

Private Const BFFM_INITIALIZED      As Long = 1
Private Const BFFM_SELCHANGED       As Long = 2
Private Const BFFM_VALIDATEFAILEDA  As Long = 3
Private Const BFFM_VALIDATEFAILEDW  As Long = 4
Private Const BFFM_IUNKNOWN         As Long = 5

Private Const WM_USER               As Long = &H400
Private Const BFFM_SETSELECTIONA    As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW    As Long = (WM_USER + 103)
Private Const BFFM_SETEXPANDED      As Long = (WM_USER + 106)

Private Const KEYEVENTF_EXTENDEDKEY     As Long = &H1
Private Const KEYEVENTF_KEYUP           As Long = &H2
Private Const WM_KEYDOWN                As Long = &H100
Private Const WM_KEYUP                  As Long = &H101
Private Const VK_ADD                    As Long = &H6B      '仮想キー(テンキー+)

Private FolderDialog_Path   As String       'フォルダ指定ダイアログ用初期パス
Private FolderDialog_UpPath As String       'フォルダ指定ダイアログ用初期パス(一つ上)
Private FolderDialog_Step   As Integer      'フォルダ指定ダイアログ用実行状況

Public Function FolderDialogOpen_TEST() As Boolean
    
    Dim strPath             As String
    
    Dim tBrowsInfo          As BROWSEINFO
    Dim strDisplayName      As String
    Dim strTitle            As String
    
    Dim objFS               As Object
    Static strPathBuffer    As String
    Dim strPathTemp         As String

    Dim pidl                As LongPtr

On Error GoTo FolderDialogOpen_TEST_Err:
    
    
    FolderDialog_Path = "C:\folder1\folder2"
    FolderDialog_UpPath = "C:\folder1"
    FolderDialog_Step = 0
    
    strDisplayName = String(MAX_PATH * 2, vbNullChar)
    
    With tBrowsInfo
        .hWndOwner = 0
        .pidlRoot = 0
        .pszDisplayName = StrPtr(strDisplayName)
        .lpszTitle = 0
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE Or BIF_NONEWFOLDERBUTTON
        .lpfn = AddressPoint(AddressOf BrowseCallbackProc)
        .lParam = 0
        .iImage = 0
    End With
    
    pidl = SHBrowseForFolder(tBrowsInfo)
    If pidl = 0 Then
        FolderDialogOpen_TEST = False
    Else
        strPath = String(MAX_PATH * 2, vbNullChar)
        Call SHGetPathFromIDList(pidl, ByVal StrPtr(strPath))
        Call CoTaskMemFree(pidl)
        strPath = Left(strPath, InStr(strPath, vbNullChar & vbNullChar) - 1)
        Debug.Print strPath
        FolderDialogOpen_TEST = True
    End If

FolderDialogOpen_TEST_End:
Exit Function

FolderDialogOpen_TEST_Err:
    '----- エラー処理
    FolderDialogOpen_TEST = False
Resume FolderDialogOpen_TEST_End:
End Function

Private Function AddressPoint(lngAddressOf As LongPtr) As LongPtr
    AddressPoint = lngAddressOf
End Function

Private Function BrowseCallbackProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal lParam As LongPtr, ByVal lpData As LongPtr) As Long
    Dim strPath         As String
    Dim strClassName    As String
    Dim strWindowName   As String
    
    Dim hWndChild       As LongPtr
    Dim hWndTreeView    As LongPtr

    If FolderDialog_Step < 9 Then
        Select Case uMsg
            Case BFFM_INITIALIZED
                '----- 一つ上のフォルダを選択
                If FolderDialog_Step = 0 And Len(FolderDialog_UpPath) > 0 Then
                    Call SendMessage(hwnd, BFFM_SETSELECTIONW, True, ByVal StrPtr(FolderDialog_UpPath))
                    FolderDialog_Step = 1    '処理待機1
                Else
                    FolderDialog_Step = 9    '処理終了
                End If
            
            Case BFFM_SELCHANGED
                If FolderDialog_Step = 2 Then   '処理待機2
                    '----- 選択されたパス取得
                    strPath = String(MAX_PATH * 2, vbNullChar)
                    Call SHGetPathFromIDList(lParam, StrPtr(strPath))
                    strPath = Left(strPath, InStr(strPath, vbNullChar & vbNullChar) - 1)
                    
                    '----- 指定されたパスが選択されている場合
                    If strPath = FolderDialog_UpPath Then
                        '----- フォルダを選択ダイアログのコントロール取得
                        strClassName = "SHBrowseForFolder ShellNameSpace Control"
                        strWindowName = vbNullString
                        hWndChild = FindWindowEx(hwnd, 0, StrPtr(strClassName), StrPtr(strWindowName))
                        
                        If hWndChild <> 0 Then
                            '----- フォルダを選択ダイアログのツリービュー取得
                            strClassName = "SysTreeView32"
                            strWindowName = vbNullString
                            hWndTreeView = FindWindowEx(hWndChild, 0, StrPtr(strClassName), StrPtr(strWindowName))
                            
                            If hWndChild <> 0 Then
                                '----- テンキー[+]を送信(ツリー展開)
                                Call SendMessage(hWndTreeView, WM_KEYDOWN, VK_ADD, 0)
                                Call SendMessage(hWndTreeView, WM_KEYUP, VK_ADD, 0)
                                
                                '----- フォルダを選択
                                If FolderDialog_UpPath <> FolderDialog_Path _
                                And Len(FolderDialog_Path) > 0 Then
                                    Call SendMessage(hwnd, BFFM_SETSELECTIONW, True, ByVal StrPtr(FolderDialog_Path))
                                End If
                            End If
                        End If
                        FolderDialog_Step = 9    '処理終了
                    End If
                End If
            
            Case BFFM_VALIDATEFAILEDA
            Case BFFM_VALIDATEFAILEDW
            Case BFFM_IUNKNOWN
                If FolderDialog_Step < 2 Then FolderDialog_Step = 2   '処理待機2
        End Select
    End If
End Function