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

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

Private Sub TESTOne()

MsgBox GetFolder(, CurrentProject.Path, "Выберете папку для экспорта ...")

'Из формы:

MsgBox GetFolder(Me.hWnd, "C:\", "Выберете папку для экспорта отчётов...")

End Sub

Модуль:

Option Explicit

'--------------------------------------------------------------------

' Module : modOpenFolder_API

' Author : es

' Date : 17.02.2011 - L.E. 01.02.2017

' Purpose : Диалог открытия Папки с заданием Начальной папки

'--------------------------------------------------------------------

'По материалам : 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 GetFolder(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 GetFolder_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

GetFolder = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)

Else

GetFolder = ""

End If

End If

GetFolder_Bye:

Exit Function

GetFolder_Err:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

"in procedure GetFolder", vbCritical, "Error!"

Resume GetFolder_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