Окно выбора директории (папки)

Public Enum SpecialFolderIDs
    sfidDESKTOP = &H0   'рабочий стол
    sfidPROGRAMS = &H2
    sfidPERSONAL = &H5
    sfidFAVORITES = &H6
    sfidSTARTUP = &H7
    sfidRECENT = &H8
    sfidSENDTO = &H9
    sfidSTARTMENU = &HB
    sfidDESKTOPDIRECTORY = &H10
    sfidNETHOOD = &H13
    sfidFONTS = &H14
    sfidTEMPLATES = &H15
    sfidCOMMON_STARTMENU = &H16
    sfidCOMMON_PROGRAMS = &H17
    sfidCOMMON_STARTUP = &H18
    sfidCOMMON_DESKTOPDIRECTORY = &H19
    sfidAPPDATA = &H1A
    sfidPRINTHOOD = &H1B
    sfidProgramFiles = &H10000
    sfidCommonFiles = &H10001
End Enum
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Const NOERROR = 0
Dim sPath As String
Dim IDL As Long
Dim strPath As String
Dim lngPos As Long
 
 
Public Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
    If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
    .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
    If .Show <> -1 Then Exit Function
    GetFolderPath = .SelectedItems(1)
    If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function

Option Explicit
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
    pvReserved As Long
    dwReserved As Long
    FlagsEx As Long
End Type
Public Enum CdlgExt_Flags
    OFNAllowMultiselect = &H200
    OFNCreatePrompt = &H2000
    OFNexplorer = &H80000
    OFNEnableHook = &H20
    OFNExtensionDifferent = &H400
    OFNFileMustExist = &H1000
    OFNHelpButton = &H10
    OFNHideReadOnly = &H4
    OFNLongNames = &H200000
    OFNNoChangeDir = &H8
    OFNNoDereferenceLinks = &H100000
    OFNNoLongNames = &H40000
    OFNNoReadOnlyReturn = &H8000
    OFNNoValidate = &H100
    OFNOverwritePrompt = &H2
    OFNPathMustExist = &H800
    OFNReadOnly = &H1
    OFNShareAware = &H4000
End Enum
Private Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type
Private Type LVITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    pszText As String
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type
 
Private Const GWL_WNDPROC = (-4)
 
Private Const WM_INITDIALOG = &H110
Private Const WM_DESTROY = &H2
Private Const WM_NOTIFY = &H4E
Private Const WM_USER = &H400
Private Const WM_COMMAND = &H111
 
Private Const CDN_FIRST = -601&
Private Const CDN_INITDONE = (CDN_FIRST - 0&)
Private Const CDN_FILEOK = (CDN_FIRST - 5&)
 
Private Const CDM_FIRST = (WM_USER + 100)
Private Const CDM_HIDECONTROL = (CDM_FIRST + &H5)
Private Const CDM_SETCONTROLTEXT = (CDM_FIRST + &H4)
Private Const CDM_GETFOLDERPATH = (CDM_FIRST + &H2)
 
Private Const BN_CLICKED As Long = &H0
 
Private Const MAX_PATH = 260
 
Private Const IDOK = 1
Private Const IDFILETYPECOMBO = &H470
Private Const IDFILETYPESTATIC = &H441      ' Files of Type
Private Const IDFILENAMESTATIC = &H442      ' File Name
Private Const IDFILELIST = &H460            ' Listbox
 
Private Const LVM_FIRST = &H1000&
Private Const LVM_GETSELECTEDCOUNT = LVM_FIRST + 50
Private Const LVM_GETNEXTITEM = (LVM_FIRST + 12)
Private Const LVM_GETITEMTEXT = LVM_FIRST + 45
 
Private Const LVIS_SELECTED = &H2&
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFilename As OPENFILENAME) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) 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 Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal Count As Long)
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
 
Dim OFN As OPENFILENAME
Dim OldWndProc As Long
Dim hwndDlg As Long
Dim mFolders As Collection
Dim mPath As String
 
Public Property Get Folders() As Collection
    Set Folders = mFolders
End Property
Public Property Get Path() As String
    Path = mPath
End Property
 
Public Function PickFolder() As String
 
    If mFolders Is Nothing Then Set mFolders = New Collection
    
    Do While mFolders.Count: mFolders.Remove (1): Loop
    
    With OFN
        .lStructSize = Len(OFN)
        .hInstance = App.hInstance
        .lpfnHook = lHookAddress(AddressOf DialogHookFunction)
        .Flags = OFNexplorer Or OFNNoChangeDir Or OFNEnableHook Or OFNHideReadOnly Or OFNAllowMultiselect
        .lpstrFile = String$(MAX_PATH, 0)
        .nMaxFile = MAX_PATH
        .lpstrFileTitle = String$(MAX_PATH, 0)
        .nMaxFileTitle = MAX_PATH
        .lpstrFilter = "Folders" & Chr$(0) & "*.ЛЮБОЕ НЕСУЩЕСТВУЮЩЕЕ РАСШИРЕНИЕ" & String$(2, Chr$(0))
        .lpstrTitle = "Pick folders"
        .nFilterIndex = 0
    End With
    GetOpenFileName OFN
End Function
 
Private Function lHookAddress(lPtr As Long) As Long
    lHookAddress = lPtr
End Function
Private Function DialogHookFunction(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case wMsg
        Case WM_INITDIALOG
            hwndDlg = GetParent(hDlg)
            OldWndProc = SetWindowLong(hwndDlg, GWL_WNDPROC, AddressOf DlgWndProc)
        Case WM_NOTIFY
            Dim tNMH As NMHDR
            CopyMemory tNMH, ByVal lParam, Len(tNMH)
            Select Case tNMH.code
            Case CDN_INITDONE
                SendMessage hwndDlg, CDM_SETCONTROLTEXT, IDOK, ByVal "Pick folder"
                SendMessage hwndDlg, CDM_SETCONTROLTEXT, IDFILENAMESTATIC, ByVal "Folder name"
                SendMessage hwndDlg, CDM_HIDECONTROL, IDFILETYPECOMBO, ByVal 0&
                SendMessage hwndDlg, CDM_HIDECONTROL, IDFILETYPESTATIC, ByVal 0&
            End Select
        Case WM_DESTROY
        Case Else
    End Select
End Function
Private Function DlgWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case Msg
    Case WM_COMMAND
        If HiWord(wParam) = BN_CLICKED Then
            Dim hwndPick As Long
                        
            hwndPick = GetDlgItem(hwndDlg, IDOK)
                        
            If lParam = hwndPick Then
                Dim hwndLVParent As Long, hwndLV As Long
                Dim Pos As Long, Itm As LVITEM, txtLen As Long
                
                hwndLVParent = FindWindowEx(hwndDlg, ByVal 0&, "SHELLDLL_DefView", vbNullString)
                hwndLV = FindWindowEx(hwndLVParent, ByVal 0&, "SysListView32", vbNullString)
 
                Pos = SendMessage(hwndLV, LVM_GETNEXTITEM, -1, ByVal LVIS_SELECTED)
                
                If Pos >= 0 Then
                    
                    Itm.cchTextMax = MAX_PATH
                    Itm.pszText = String(MAX_PATH, 0)
                    
                    txtLen = SendMessage(hwndLV, LVM_GETITEMTEXT, Pos, Itm)
                    
                    mFolders.Add Left(Itm.pszText, txtLen)
                    
                    Do Until Pos = -1
                        Pos = SendMessage(hwndLV, LVM_GETNEXTITEM, Pos, ByVal LVIS_SELECTED)
                        txtLen = SendMessage(hwndLV, LVM_GETITEMTEXT, Pos, Itm)
                        If Pos >= 0 Then mFolders.Add Left(Itm.pszText, txtLen)
                    Loop
                    
                    mPath = String(MAX_PATH, 0)
                    txtLen = SendMessage(hwndDlg, CDM_GETFOLDERPATH, MAX_PATH, ByVal mPath)
                    mPath = Left(mPath, txtLen - 1)
                    DestroyWindow hwndDlg
                End If
            Else
                DlgWndProc = CallWindowProc(OldWndProc, hwnd, Msg, wParam, lParam)
            End If
        End If
    Case Else
        DlgWndProc = CallWindowProc(OldWndProc, hwnd, Msg, wParam, lParam)
    End Select
End Function
 
Private Function LoWord(ByVal LongIn As Long) As Integer
    Call CopyMemory(LoWord, LongIn, 2)
End Function
Private Function HiWord(ByVal LongIn As Long) As Integer
    Call CopyMemory(HiWord, ByVal (VarPtr(LongIn) + 2), 2)
End Function

Private Sub cmdPick_Click()
    Dim Fld As Variant, Ret As String
    
    modGetOpenFolder.PickFolder
    
    Ret = "Parent dir: " & modGetOpenFolder.Path & vbNewLine & "Selected dir: " & vbNewLine
    For Each Fld In modGetOpenFolder.Folders
        Ret = Ret & "\" & Fld & vbNewLine
    Next
    
    MsgBox Ret
End Sub

Option Explicit
 
 
Const BIF_RETURNONLYFSDIRS = &H1&
Const BIF_EDITBOX = &H10&
Const BIF_NEWDIALOGSTYLE = &H40&
Const BIF_USENEWUI = BIF_EDITBOX Or BIF_NEWDIALOGSTYLE
Const BIF_NONEWFOLDERBUTTON = &H200&
Const BIF_SHAREABLE = &H8000&
 
Private Sub Command1_Click()
    Dim Folder As Object
    
    With CreateObject("Shell.Application")
        Set Folder = .BrowseForFolder(hWnd, "Pick a folder", BIF_RETURNONLYFSDIRS _
                                                          Or BIF_SHAREABLE _
                                                          Or BIF_USENEWUI _
                                                          Or BIF_NEWDIALOGSTYLE _
                                                          Or BIF_NONEWFOLDERBUTTON)
    End With
    
    If Folder Is Nothing Then
        MsgBox "cancel"
    Else
        Me.Caption = Folder.Self.Path
    End If
End Sub