2024/03/11(Mon) 12:42:12 編集(投稿者)
'こちらが現在の状態のコードです
'実行は
'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
このトピックをツリーで一括表示