Если Вы ищите информацию об использовании объекта 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
' 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
' 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
...
' 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
...