Из KRa: VBA FileDialog vs вызов SHBrowseForFolder для выбора каталога
Если Вы ищите информацию об использовании объекта FileDialog в VBA, то она здесь. А если информацию о FileSearch, то, например, здесь.
У Microsoft и KB и MSDN написаны понятным языком и в открытом доступе. Теперь даже и по русски ...
А здесь написано о мелкой мелочи : что делать если код должен работать и с Office XP, где FileDialog есть, и с Office 2000, где FileDialog нет.
Если так, пишем две реализации - одну для Office 9.0 или меньше, другую - для Office 10.0 или больше. Я, правда, в припадке энтузиазма сделал то же самое и для FileSearch, который в Excel 2000 есть. То ли я его не заметил, то ли он мне чем-то не понравился.
Реализация для XP на базе "родных" объектов:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' KraModuleExt - реализация процедур выбора фолдера и получения ' ' списка фалов, основанных на внутренних возможностях (Для Ехсеl XP) ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit ' ******************************************************* ' Выбор фолдера с помощью внутренних возможностей Excel ' Возвращает выбранный фолдер или Nil, если юзер нажал Cancel ' Public Function SelectFolder() As String ' Создаем FileDialog object как "Folder Picker dialog box". ' Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) ' Запрещаем выбор нескольких папок. fd.AllowMultiSelect = False 'Show = -1 значит, что Юзер нажал OK(Да) If fd.Show = -1 Then SelectFolder = fd.SelectedItems(1) Else SelectFolder = "" End If End Function ' ******************************************************* ' Поиск файлов с расширением *.xls в заданном каталоге средствами Excel XP ' Возвращает коллекцию полных имен файлов (с путем) Public Function SearchFiles(SearchPath As String) As Collection Dim Res As New Collection Dim fs As FileSearch Set fs = Application.FileSearch With fs .LookIn = SearchPath .FileName = "*.xls" If .Execute(AlwaysAccurate:=True) > 0 Then Dim I As Integer For I = 1 To .FoundFiles.Count Res.Add (.FoundFiles.Item(I)) Next I ' To .FoundFiles.Count End If ' .Execute(AlwaysAccurate:=True) > 0 End With ' fs Set fs = Nothing Set SearchFiles = Res End Function
Реализация для 2000 с использованием shell:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' KraModuleExt9 - реализация процедур выбора фолдера и получения ' ' списка файлов путем вызова функций OS (Для Ехсеl 2000) ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Option Explicit ' ******************************************************* ' ' SHBrowseForFolder Constants ' ' ******************************************************* ' For finding a folder to start document searching Private Const BIF_RETURNONLYFSDIRS As Long = &H1 ' For starting the Find Computer Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ' Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if ' this flag is set. Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the ' rest of the text. This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets ' all three lines of text. Private Const BIF_STATUSTEXT As Long = &H4 Private Const BIF_RETURNFSANCESTORS As Long = &H8 ' Add an editbox to the dialog Private Const BIF_EDITBOX As Long = &H10 ' insist on valid result (or CANCEL) Private Const BIF_VALIDATE As Long = &H20 ' Use the new dialog layout with the ability to resize ' Caller needs to call OleInitialize() before using this API Private Const BIF_NEWDIALOGSTYLE As Long = &H40 Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX) ' Allow URLs to be displayed or entered. (Requires BIF_USENEWUI) Private Const BIF_BROWSEINCLUDEURLS As Long = &H80 ' Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX Private Const BIF_UAHINT As Long = &H100 ' Do not add the "New Folder" button to the dialog. Only applicable with BIF_NEWDIALOGSTYLE. Private Const BIF_NONEWFOLDERBUTTON As Long = &H200 ' don't traverse target as shortcut Private Const BIF_NOTRANSLATETARGETS As Long = &H400 ' Browsing for Computers. Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 ' Browsing for Printers Private Const BIF_BROWSEFORPRINTER As Long = &H2000 ' Browsing for Everything Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 ' sharable resources displayed (remote shares, requires BIF_USENEWUI) Private Const BIF_SHAREABLE As Long = &H8000 ' ******************************************************* ' ' FILE_ATTRIBUTE Constants ' ' ******************************************************* Private Const FILE_ATTRIBUTE_READONLY As Long = &H1 ' The file or directory is read-only. Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2 ' The file or directory is hidden Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4 ' The file or directory is part of the operating system or ' is used exclusively by the operating system. Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10 ' The handle identifies a directory. Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20 ' The file or directory is an archive file or directory. Private Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H40 ' The file or directory is encrypted. Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 ' The file or directory has no other attributes set. Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100 ' The file is being used for temporary storage. Private Const FILE_ATTRIBUTE_SPARSE_FILE As Long = &H200 ' The file is a sparse file. Private Const FILE_ATTRIBUTE_REPARSE_POINT As Long = &H400 ' The file has an associated reparse point. Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800 ' The file or directory is compressed. Private Const FILE_ATTRIBUTE_OFFLINE As Long = &H1000 ' The file data is not immediately available. Private Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED As Long = &H2000 Private Const INVALID_HANDLE_VALUE = -1 Public Const MAX_PATH = 260 ' ******************************************************* ' ' SHBrowseForFolder Structure ' ' ******************************************************* Private Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type ' ******************************************************* ' ' FILETIME Structure ' ' ******************************************************* Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type ' ******************************************************* ' ' WIN32_FIND_DATA Structure ' ' ******************************************************* Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternateFileName As String * 14 End Type ' ******************************************************* ' ' SHBrowseForFolder Function ' Displays a dialog box that enables the user to select a Shell folder. ' ' ******************************************************* Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long ' ******************************************************* ' ' SHGetPathFromIDList Function ' Converts an item identifier list to a file system path. ' ' ******************************************************* Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long '******************************************************* ' ' lstrcat Function ' The lstrcat function appends one string to another. ' ' ******************************************************* Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _ ByVal lpString2 As String) As Long ' ******************************************************* ' ' FindFirstFile Function ' Searches a directory for a file whose name matches the specified file name ' ' ******************************************************* Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"(ByVal lpFileName As Long, _ lpFinfFileData As WIN32_FIND_DATA) As Long ' ******************************************************* ' ' FindNextFile Function ' Continues a file search from a previous call to the FindFirstFile function ' ' ******************************************************* Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, _ lpFinfFileData As WIN32_FIND_DATA) As Long ' ******************************************************* ' ' FindClose Function ' Closes the specified search handle ' ' ******************************************************* Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long ' ******************************************************* ' ' GetLastError Function ' Retrieves the calling thread's last-error code value ' ' ******************************************************* Private Declare Function GetLastError Lib "kernel32" () As Long ' ******************************************************* ' Выбор фолдера с помощью функций shell ' Возвращает выбранный фолдер или Nil, если юзер нажал Cancel ' Public Function SelectFolder() As String Dim lpIDList As Long Dim sBuffer As String Dim szTitle As String Dim tBrowseInfo As BrowseInfo szTitle = "Папка для загрузки прайс-листов:" With tBrowseInfo .hWndOwner = Application.hWnd .lpszTitle = lstrcat(szTitle, "") .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + _ BIF_NEWDIALOGSTYLE + BIF_NONEWFOLDERBUTTON + BIF_SHAREABLE End With ' tBrowseInfo lpIDList = SHBrowseForFolder(tBrowseInfo) If (lpIDList) Then sBuffer = Space(MAX_PATH) SHGetPathFromIDList lpIDList, sBuffer sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) SelectFolder = sBuffer Else ' lpIDList SelectFolder = "" End If ' lpIDList End Function ' ******************************************************* ' Поиск файлов с расширением *.xls в заданном каталоге средствами Windows ' Возвращает коллекцию полных имен файлов (с путем) Public Function SearchFiles(SearchPath As String) As Collection Dim Res As New Collection Dim hSearch, dwSearchRes, dwError As Long Dim FileData As WIN32_FIND_DATA Dim SearchPath1 As String Dim SearchPathA As Long SearchPath1 = SearchPath & "\*.xls" SearchPathA = lstrcat(SearchPath1, "") hSearch = FindFirstFile(SearchPathA, FileData) If hSearch <> INVALID_HANDLE_VALUE Then Do Res.Add (SearchPath & "\" + Left(FileData.cFileName, InStr(FileData.cFileName, vbNullChar) - 1)) dwSearchRes = FindNextFile(hSearch, FileData) Loop Until dwSearchRes = 0 dwSearchRes = FindClose(hSearch) End If ' hSearch <> INVALID_FILE_HANDLE Set SearchFiles = Res End Function
И наслаждаемся открывшимися возможностями:
' ******************************************************* ' Excel XP -- версия "10.0" ' Excel 2000 -- версия "9.0" ' В зависимости от версии для выбора каталога и построения списка файлов используются либо встроенные возможности, ' либо функции shell If Left(Application.Version, 1) <> "1" Then vrtSelectedFolder = KraModuleExt9.SelectFolder() Else ' Application.Version vrtSelectedFolder = KraModuleExt10.SelectFolder() End If ' Application.Version If Not vrtSelectedFolder = "" Then Dim fs As Collection If Left(Application.Version, 1) <> "1" Then Set fs = KraModuleExt9.SearchFiles(vrtSelectedFolder) Else ' Application.Version Set fs = KraModuleExt10.SearchFiles(vrtSelectedFolder) End If ' Application.Version ...^ TOP
