TopPicLogo TopPicText

Диалог открытия Папки (API)

Примеры вызова:

Private Sub TESTOne()
    MsgBox esOpenFolder(, CurrentProject.Path)

'Из формы:
    MsgBox esOpenFolder(Me.hWnd, "C:\", "Выберете папку для экспорта отчётов...")
End Sub



Модуль:

'--------------------------------------------------------------------
' Module    : modOpenFolder
' Author    : es
' Date      : 17.02.2011 - L.E. 16.11.2012
' Purpose   : Диалог открытия Папки с заданием Начальной папки
'--------------------------------------------------------------------
Option Compare Database
Option Explicit
'По материалам : http://bit.pirit.info/forum/viewtopic.php?t=7432
'                http://www.cpearson.com/excel/browsefolder.aspx
'--------------------------------------------------------------------

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SETSELECTION As Long = WM_USER + 102

Private slRootFolder As String

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

Private Type BrowseInfo
    hWndOwner      As Long
    pIDLRoot       As Long
    pszDisplayName As String
    lpstrTitle     As String
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type



Public Function esOpenFolder(Optional ByVal hWnd As Long = 0, Optional ByVal strRootFolder As String = "", _
            Optional ByVal strTitle As String = "") As String
Dim lpIDList As Long
Dim sBuffer As String
Dim lBrowseInfo As BrowseInfo
Dim lngRet As Long
'Возвращает путь к выбранной папке или пустую строку (при отмене)
'--------------------------------------------------------------------
On Error GoTo esOpenFolder_Err
    With lBrowseInfo
        .hWndOwner = hWnd
        .lpstrTitle = strTitle
        .pIDLRoot = 0
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lParam = 0
    End With

    If strRootFolder <> "" Then
        slRootFolder = strRootFolder
        CopyMemory lBrowseInfo.lpfnCallback, AddressOf BrowseCallbackProc, 4
    End If


    sBuffer = String$(MAX_PATH, vbNullChar)
    lpIDList = SHBrowseForFolder(lBrowseInfo)

    If lpIDList Then
        lngRet = SHGetPathFromIDList(lpIDList, sBuffer)
        If lngRet Then
            esOpenFolder = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        Else
            esOpenFolder = ""
        End If
    End If

esOpenFolder_Bye:
    Exit Function

esOpenFolder_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure esOpenFolder", vbCritical, "Error!"
    Resume esOpenFolder_Bye

End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
        SendMessage hWnd, BFFM_SETSELECTION, 1, slRootFolder
    End If
    BrowseCallbackProc = 0
End Function


Назад ToTop
L.E. 17.05.2015
Рейтинг@Mail.ru