Перейти к основному содержанию.

Из 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 на базе "родных" объектов: 

  1. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  2. ' KraModuleExt - реализация процедур выбора фолдера и получения       '
  3. ' списка фалов, основанных на внутренних возможностях (Для Ехсеl XP)  '
  4. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  5. Option Explicit
  6.  
  7. ' *******************************************************
  8. ' Выбор фолдера с помощью внутренних возможностей Excel
  9. ' Возвращает выбранный фолдер или Nil, если юзер нажал Cancel
  10. '
  11. Public Function SelectFolder() As String
  12. ' Создаем FileDialog object как "Folder Picker dialog box".
  13. '
  14.     Dim fd As FileDialog
  15.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  16.  
  17. ' Запрещаем выбор нескольких папок.
  18.     fd.AllowMultiSelect = False
  19.  
  20. 'Show = -1 значит, что Юзер нажал OK(Да)
  21.     If fd.Show = -1 Then
  22.         SelectFolder = fd.SelectedItems(1)
  23.     Else
  24.         SelectFolder = ""
  25.     End If
  26.          
  27. End Function
  28.  
  29. ' *******************************************************
  30. ' Поиск файлов с расширением *.xls в заданном каталоге средствами Excel XP
  31. ' Возвращает коллекцию полных имен файлов (с путем)
  32. Public Function SearchFiles(SearchPath As String) As Collection
  33.     
  34.     Dim Res As New Collection
  35.     Dim fs As FileSearch
  36.     Set fs = Application.FileSearch
  37.     With fs
  38.         .LookIn = SearchPath
  39.         .FileName = "*.xls"
  40.  
  41.         If .Execute(AlwaysAccurate:=True) > 0 Then
  42.             Dim I As Integer
  43.             For I = 1 To .FoundFiles.Count
  44.                 Res.Add (.FoundFiles.Item(I))
  45.             Next I ' To .FoundFiles.Count
  46.         End If ' .Execute(AlwaysAccurate:=True) > 0
  47.     End With  ' fs
  48.     
  49.     Set fs = Nothing
  50.     Set SearchFiles = Res
  51. End Function
  52.

Реализация для 2000 с использованием shell: 

  1. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  2. ' KraModuleExt9 - реализация процедур выбора фолдера и получения      '
  3. ' списка файлов путем вызова функций OS  (Для Ехсеl 2000)             '
  4. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  5. Option Explicit
  6.  
  7. ' *******************************************************
  8. '
  9. '   SHBrowseForFolder Constants
  10. '
  11. ' *******************************************************
  12. ' For finding a folder to start document searching
  13. Private Const BIF_RETURNONLYFSDIRS As Long = &H1
  14. ' For starting the Find Computer  
  15. Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 
  16. ' Top of the dialog has 2 lines of text for BROWSEINFO.lpszTitle and one line if
  17. ' this flag is set.  Passing the message BFFM_SETSTATUSTEXTA to the hwnd can set the
  18. ' rest of the text.  This is not used with BIF_USENEWUI and BROWSEINFO.lpszTitle gets
  19. ' all three lines of text.
  20. Private Const BIF_STATUSTEXT As Long = &H4        
  21. Private Const BIF_RETURNFSANCESTORS As Long = &H8
  22. ' Add an editbox to the dialog
  23. Private Const BIF_EDITBOX As Long = &H10
  24. ' insist on valid result (or CANCEL)         
  25. Private Const BIF_VALIDATE As Long = &H20         
  26. ' Use the new dialog layout with the ability to resize
  27. ' Caller needs to call OleInitialize() before using this API
  28. Private Const BIF_NEWDIALOGSTYLE As Long = &H40   
  29. Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX)
  30. ' Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)
  31. Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
  32. ' Add a UA hint to the dialog, in place of the edit box. May not be combined with BIF_EDITBOX    
  33. Private Const BIF_UAHINT As Long = &H100              
  34. ' Do not add the "New Folder" button to the dialog.  Only applicable with BIF_NEWDIALOGSTYLE.
  35. Private Const BIF_NONEWFOLDERBUTTON As Long = &H200   
  36. ' don't traverse target as shortcut
  37. Private Const BIF_NOTRANSLATETARGETS As Long = &H400  
  38. ' Browsing for Computers.
  39. Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
  40. ' Browsing for Printers  
  41. Private Const BIF_BROWSEFORPRINTER As Long = &H2000   
  42. ' Browsing for Everything
  43. Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 
  44. ' sharable resources displayed (remote shares, requires BIF_USENEWUI)
  45. Private Const BIF_SHAREABLE As Long = &H8000          
  46.  
  47. ' *******************************************************
  48. '
  49. '   FILE_ATTRIBUTE Constants
  50. '
  51. ' *******************************************************
  52. Private Const FILE_ATTRIBUTE_READONLY As Long = &H1         ' The file or directory is read-only.
  53. Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2           ' The file or directory is hidden
  54. Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4           ' The file or directory is part of the operating system or 
  55.                                                             ' is used exclusively by the operating system.
  56. Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10       ' The handle identifies a directory.
  57. Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20         ' The file or directory is an archive file or directory.
  58. Private Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H40       ' The file or directory is encrypted.
  59. Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80          ' The file or directory has no other attributes set.
  60. Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100      ' The file is being used for temporary storage.
  61. Private Const FILE_ATTRIBUTE_SPARSE_FILE As Long = &H200    ' The file is a sparse file.
  62. Private Const FILE_ATTRIBUTE_REPARSE_POINT As Long = &H400  ' The file has an associated reparse point.
  63. Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800     ' The file or directory is compressed.
  64. Private Const FILE_ATTRIBUTE_OFFLINE As Long = &H1000       ' The file data is not immediately available.
  65. Private Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED As Long = &H2000
  66.  
  67. Private Const INVALID_HANDLE_VALUE = -1
  68. Public Const MAX_PATH = 260
  69.  
  70. ' *******************************************************
  71. '
  72. '   SHBrowseForFolder Structure
  73. '
  74. ' *******************************************************
  75. Private Type BrowseInfo
  76.          hWndOwner      As Long
  77.          pIDLRoot       As Long
  78.          pszDisplayName As Long
  79.          lpszTitle      As Long
  80.          ulFlags        As Long
  81.          lpfnCallback   As Long
  82.          lParam         As Long
  83.          iImage         As Long
  84. End Type
  85.  
  86. ' *******************************************************
  87. '
  88. '   FILETIME Structure
  89. '
  90. ' *******************************************************
  91. Private Type FILETIME
  92.          dwLowDateTime      As Long
  93.          dwHighDateTime     As Long
  94. End Type
  95.  
  96. ' *******************************************************
  97. '
  98. '   WIN32_FIND_DATA Structure
  99. '
  100. ' *******************************************************
  101. Private Type WIN32_FIND_DATA
  102.          dwFileAttributes      As Long
  103.          ftCreationTime        As FILETIME
  104.          ftLastAccessTime      As FILETIME
  105.          ftLastWriteTime       As FILETIME
  106.          nFileSizeHigh         As Long
  107.          nFileSizeLow          As Long
  108.          dwReserved0           As Long
  109.          dwReserved1           As Long
  110.          cFileName             As String * MAX_PATH
  111.          cAlternateFileName    As String * 14
  112. End Type
  113.  
  114. ' *******************************************************
  115. '
  116. '   SHBrowseForFolder Function
  117. '   Displays a dialog box that enables the user to select a Shell folder.
  118. '
  119. ' *******************************************************
  120. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  121.  
  122. ' *******************************************************
  123. '
  124. '   SHGetPathFromIDList Function
  125. '   Converts an item identifier list to a file system path.
  126. '
  127. ' *******************************************************
  128. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  129.  
  130. '*******************************************************
  131. '
  132. '   lstrcat Function
  133. '   The lstrcat function appends one string to another.
  134. '
  135. ' *******************************************************
  136. Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
  137.                          ByVal lpString2 As String) As Long
  138.  
  139. ' *******************************************************
  140. '
  141. '   FindFirstFile Function
  142. '   Searches a directory for a file whose name matches the specified file name
  143. '
  144. ' *******************************************************
  145. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"(ByVal lpFileName As Long, _
  146.                          lpFinfFileData As WIN32_FIND_DATA) As Long
  147.  
  148. ' *******************************************************
  149. '
  150. '   FindNextFile Function
  151. '   Continues a file search from a previous call to the FindFirstFile function
  152. '
  153. ' *******************************************************
  154. Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, _
  155.                          lpFinfFileData As WIN32_FIND_DATA) As Long
  156.  
  157. ' *******************************************************
  158. '
  159. '   FindClose Function
  160. '   Closes the specified search handle
  161. '
  162. ' *******************************************************
  163. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  164.  
  165. ' *******************************************************
  166. '
  167. '   GetLastError Function
  168. '   Retrieves the calling thread's last-error code value
  169. '
  170. ' *******************************************************
  171. Private Declare Function GetLastError Lib "kernel32" () As Long                                     
  172.  
  173. ' *******************************************************
  174. ' Выбор фолдера с помощью функций shell
  175. ' Возвращает выбранный фолдер или Nil, если юзер нажал Cancel
  176. '
  177. Public Function SelectFolder() As String
  178.       
  179.     Dim lpIDList As Long
  180.     Dim sBuffer As String
  181.     Dim szTitle As String
  182.     Dim tBrowseInfo As BrowseInfo
  183.  
  184.     szTitle = "Папка для загрузки прайс-листов:"
  185.     With tBrowseInfo
  186.         .hWndOwner = Application.hWnd
  187.         .lpszTitle = lstrcat(szTitle, "")
  188.         .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + _
  189.                    BIF_NEWDIALOGSTYLE + BIF_NONEWFOLDERBUTTON + BIF_SHAREABLE
  190.     End With  ' tBrowseInfo
  191.  
  192.     lpIDList = SHBrowseForFolder(tBrowseInfo)
  193.  
  194.     If (lpIDList) Then
  195.         sBuffer = Space(MAX_PATH)
  196.         SHGetPathFromIDList lpIDList, sBuffer
  197.         sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
  198.         SelectFolder = sBuffer
  199.     Else ' lpIDList
  200.         SelectFolder = ""
  201.     End If ' lpIDList
  202.          
  203. End Function
  204.  
  205. ' *******************************************************
  206. ' Поиск файлов с расширением *.xls в заданном каталоге средствами Windows
  207. ' Возвращает коллекцию полных имен файлов (с путем)
  208. Public Function SearchFiles(SearchPath As String) As Collection
  209.     
  210.     Dim Res As New Collection
  211.     Dim hSearch, dwSearchRes, dwError As Long
  212.     Dim FileData As WIN32_FIND_DATA
  213.     Dim SearchPath1 As String
  214.     Dim SearchPathA As Long
  215.         
  216.     SearchPath1 = SearchPath & "\*.xls"
  217.     SearchPathA = lstrcat(SearchPath1, "")
  218.     hSearch = FindFirstFile(SearchPathA, FileData)
  219.     If hSearch <> INVALID_HANDLE_VALUE Then
  220.         Do
  221.             Res.Add (SearchPath & "\" + Left(FileData.cFileName, InStr(FileData.cFileName, vbNullChar) - 1))
  222.             dwSearchRes = FindNextFile(hSearch, FileData)
  223.         Loop Until dwSearchRes = 0
  224.         dwSearchRes = FindClose(hSearch)
  225.     End If ' hSearch <> INVALID_FILE_HANDLE
  226.     Set SearchFiles = Res
  227. End Function
  228.

И наслаждаемся открывшимися возможностями: 

  1. ' *******************************************************
  2. ' Excel XP -- версия "10.0"
  3. ' Excel 2000 -- версия "9.0"
  4. ' В зависимости от версии для выбора каталога и построения списка файлов используются либо встроенные возможности, 
  5. ' либо функции shell
  6.     
  7.     If Left(Application.Version, 1) <> "1" Then
  8.         vrtSelectedFolder = KraModuleExt9.SelectFolder()
  9.     Else        ' Application.Version
  10.         vrtSelectedFolder = KraModuleExt10.SelectFolder()
  11.     End If      ' Application.Version
  12.     
  13.     If Not vrtSelectedFolder = "" Then
  14.                   
  15.         Dim fs As Collection
  16.         If Left(Application.Version, 1) <> "1" Then
  17.             Set fs = KraModuleExt9.SearchFiles(vrtSelectedFolder)
  18.         Else     ' Application.Version
  19.             Set fs = KraModuleExt10.SearchFiles(vrtSelectedFolder)
  20.         End If   ' Application.Version
  21.         ...
  22.
^ TOP

01/07/2007

Комментарии

 
( ):