Просмотр содержимого папки

Листинг 3.100. Просмотр содержимого папки

' Объявление API-функции для отображения стандартного окна _

просмотра папок

Declare Function SHBrowseForFolder Lib " shell32.dll" _

Alias " SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

' Объявление API-функции для преобразования данных, возвращаемых _

функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib " shell32.dll" _

Alias " SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _

pszPath As String) As Long

' Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

hwndOwner As Long ' Родительское окно (для диалога)

pidlRoot As Long ' Корневая папка для просмотра

strDisplayName As String

strTitle As String ' Заголовок окна

ulFlags As Long ' Флаги для окна

' Следующие три параметра в VBA не используются

lpfn As Long

lParam As Long

iImage As Long

End Type

Sub BrowseFolder()

Dim strPath As String ' Папка, список файлов которой выводится

Dim strFile As String

Dim intRow As Long ' Текущая строка таблицы

' Выбор папки

strPath = dhBrowseForFolder()

If strPath = " " Then Exit Sub

If Right(strPath, 1) < > " \" Then strPath = strPath & " \"

' Оформление заголовка отчета

ActiveSheet.Cells.ClearContents

ActiveSheet.Cells(1, 1) = " Имя файла"

ActiveSheet.Cells(1, 2) = " Размер"

ActiveSheet.Cells(1, 3) = " Дата/время"

ActiveSheet.Range(" A1: C1").Font.Bold = True

' Просмотр объектов в папке...

' Первый объект папки

strFile = Dir(strPath, 7)

intRow = 2

Do While strFile < > " "

' Запись в столбец " A" имени файла

ActiveSheet.Cells(intRow, 1) = strFile

' Запись в столбец " B" размера файла

ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

' Запись в столбец " C" времени изменения файла

ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

' Следующий объект папки

strFile = Dir

intRow = intRow + 1

Loop

End Sub

Function dhBrowseForFolder() As String

Dim biBrowse As BROWSEINFO

Dim strPath As String

Dim lngResult As Long

Dim intLen As Integer

' Заполнение полей структуры BROWSEINFO

' Корневая папка - Рабочий стол

biBrowse.pidlRoot = 0&

' Заголовок окна

biBrowse.strTitle = " Выбор папки"

' Тип возвращаемой папки

biBrowse.ulFlags = & H1

' Вывод стандартного окна просмотра папок

lngResult = SHBrowseForFolder(biBrowse)

' Обработка результата работы окна

If lngResult Then

' Получение пути (по возвращенным данным)

strPath = Space$(512)

If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

' Строка пути заканчивается символом Chr(0)

intLen = InStr(strPath, Chr$(0))

' Выделение и возврат пути

dhBrowseForFolder = Left(strPath, intLen - 1)

Else

' Не удалось получить путь

dhBrowseForFolder = " "

End If

Else

' Пользователь нажал кнопку " Отмена"

dhBrowseForFolder = " "

End If

End Function

Листинг 3.101. Просмотр содержимого папки с указанием полного пути к файлам

' Объявление API-функции для отображения стандартного окна _

просмотра папок

Declare Function SHBrowseForFolder Lib " shell32.dll" _

Alias " SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

' Объявление API-функции для преобразования данных, возвращаемых _

функцией SHBrowseForFolder, в строку

Declare Function SHGetPathFromIDList Lib " shell32.dll" _

Alias " SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _

pszPath As String) As Long

' Структура используется функцией SHBrowseForFolder

Type BROWSEINFO

hwndOwner As Long ' Родительское окно (для диалога)

pidlRoot As Long ' Корневая папка для просмотра

strDisplayName As String

strTitle As String ' Заголовок окна

ulFlags As Long ' Флаги для окна

' Следующие три параметра в VBA не используются

lpfn As Long

lParam As Long

iImage As Long

End Type

Sub BrowseFolder1()

Dim strPath As String ' Папка, список файлов которой выводится

Dim strFile As String

Dim intRow As Long ' Текущая строка таблицы

' Выбор папки

strPath = dhBrowseForFolder()

If strPath = " " Then Exit Sub

If Right(strPath, 1) < > " \" Then strPath = strPath & " \"

' Оформление заголовка отчета

ActiveSheet.Cells.ClearContents

ActiveSheet.Cells(1, 1) = " Имя файла"

ActiveSheet.Cells(1, 2) = " Размер"

ActiveSheet.Cells(1, 3) = " Дата/время"

ActiveSheet.Range(" A1: C1").Font.Bold = True

' Просмотр объектов в папке...

' Первый объект папки

strFile = Dir(strPath, 7)

intRow = 2

Do While strFile < > " "

' Запись в столбец " A" имени файла

ActiveSheet.Cells(intRow, 1) = strPath & strFile

' Запись в столбец " B" размера файла

ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)

' Запись в столбец " C" времени изменения файла

ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath & strFile)

' Следующий объект папки

strFile = Dir

intRow = intRow + 1

Loop

End Sub

Function dhBrowseForFolder() As String

Dim biBrowse As BROWSEINFO

Dim strPath As String

Dim lngResult As Long

Dim intLen As Integer

' Заполнение полей структуры BROWSEINFO

' Корневая папка - Рабочий стол

biBrowse.pidlRoot = 0&

' Заголовок окна

biBrowse.strTitle = " Выбор папки"

' Тип возвращаемой папки

biBrowse.ulFlags = & H1

' Выводим стандартное окно просмотра папок

lngResult = SHBrowseForFolder(biBrowse)

' Обработка результата работы окна

If lngResult Then

' Получение пути (по возвращенным данным)

strPath = Space$(512)

If SHGetPathFromIDList(ByVal lngResult, ByVal strPath) Then

' Строка пути заканчивается символом Chr(0)

intLen = InStr(strPath, Chr$(0))

' Выделение и возврат пути

dhBrowseForFolder = Left(strPath, intLen - 1)

Else

' Не удалось получить путь

dhBrowseForFolder = " "

End If

Else

' Пользователь нажал кнопку " Отмена" в окне

dhBrowseForFolder = " "

End If

End Function