MyTetra Share
Делитесь знаниями!
Диалог открытия Папки (API)
19.07.2018
19:31
Раздел: VBA - Access - msa.polarcom.ru - 12 Папки и Файлы


Диалог открытия Папки (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













Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования