Форумы HiProg.com - MS ACCESS, VBA, VB

ник: osmor
Варианты :

Public Function SelectFolderDialog(Optional strInitialDir As String, _     Optional strTitle As String = "Выбор папки", _     Optional ByVal strButtonName As String, _     Optional ByVal hWnd As Long) As String Dim ret As Long, strFile As String          WizHook.Key = 51488399    If hWnd = 0 Then hWnd = Application.hWndAccessApp     strFile = String(255, Chr(0))          ret = WizHook.GetFileName(hWnd, "", strTitle, strButtonName, _         strFile, strInitialDir, "*.*", 0, 0, 32, True)          ' Проверим, не произошел ли возврат в результате нажатия клавиши Esc (-302)  If ret <> -302 Then     SelectFolderDialog = strFile  End If End Function 'пример вызова Debug.Print SelectFolderDialog("c:\_proj")

' нужна ссылка на Microsoft Office xx.x Object Library Function SelectFolderDialogOffice() As String   Dim dr As Object   Set dr = Application.FileDialog(msoFileDialogFolderPicker)   dr.Title = "Выбор каталога"   dr.ButtonName = "Выбрать"   dr.AllowMultiSelect = False   If dr.Show = -1 Then       SelectFolderDialogOffice = dr.SelectedItems(1)   Else         SelectFolderDialogOffice = ""   End If   Set dr = Nothing End Function 'пример вызова Debug.Print SelectFolderDialogOffice

' поместить в отдельный модуль Private Type BROWSEINFO   hOwner As Long   pidlRoot As Long   pszDisplayName As String   lpszTitle As String   ulFlags As Long   lpfn As Long   lParam As Long   iImage As Long End Type Private Const BIF_RETURNONLYFSDIRS = &H1 Public Const OFN_EXPLORER = &H80000 Public Const OFN_NOCHANGEDIR = &H8 Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Public Function BrowseFolder(szDialogTitle As String) As String  Dim x As Long, bi As BROWSEINFO, dwIList As Long  Dim szPath As String, wPos As Integer  With bi   .hOwner = hWndAccessApp   .lpszTitle = szDialogTitle   .ulFlags = BIF_RETURNONLYFSDIRS  End With  dwIList = SHBrowseForFolder(bi)  szPath = Space$(512)  x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)  If x Then   wPos = InStr(szPath, Chr(0))   BrowseFolder = Left$(szPath, wPos - 1)  Else   BrowseFolder = ""  End If End Function 'пример вызова Debug.Print BrowseFolder("Выбор папки")