' Корневая папка – Рабочий стол
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
Особенность этой программы – использование API-функций работы с объектами файловой системы Windows – SHBrowseForFolderи SHGetPathFromlDList. Первая функция отображает стандартное диалоговое окно просмотра дерева папок и возвращает целое значение, идентифицирующее выбранную папку (или О в случае отмены выбора). Вторая функция позволяет определить путь папки, идентифицируемой этим значением.
После написания данного кода в окне выбора макросов станет доступен макрос BrowseFolder. После его выполнения откроется окно Обзор папок, в котором по обычным правилам Windows следует указать путь к требуемой папке и нажать кнопку ОК. В результате на текущем рабочем листе будет сформирован перечень файлов, входящих в состав указанной папки (рис. 3.37).
Для каждой позиции данного списка в соответствующих столбцах указывается имя файла, его размер (в байтах), а также дата и время создания или последнего изменения.
Рис. 3.37. Список файлов
При необходимости можно формировать данный список с указанием полного пути к каждому файлу. В этом случае код макроса будет выглядеть следующим образом (листинг 3.98).
' Объявление 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
После написания данного кода в окне выбора макросов станет доступным макрос BrowseFolderl. Результат его выполнения показан на рис. 3.38.
Рис. 3.38. Список файлов суказанием пути
На рисунке видно, что для каждой позиции данного списка указывается полный путь к файлу.
Получение информации о состоянии дисков
При необходимости можно быстро получить и вывести на активном рабочем листе разнообразную информацию о текущем состоянии дисков компьютера. Для этого достаточно воспользоваться макросом, код которого выглядит так (листинг 3.99).
Sub DrivesInfo()
Dim objFileSysObject As Object ' Объект для работы _
с файловой системой
Dim objDrive As Object ' Анализируемый диск
Dim intRow As Integer ' Заполняемая строка листа
' Создание объекта для работы с файловой системой
Set objFileSysObject = CreateObject(«Scripting.FileSystemObject»)
' Очистка листа
Cells.Clear
' Запись с первой строки
intRow = 1
' Запись на лист информации о дисках компьютера
On Error Resume Next
For Each objDrive In objFileSysObject.Drives
' Буква диска
Cells(intRow, 1) = objDrive.DriveLetter
' Готовность
Cells(intRow, 2) = objDrive.IsReady
' Тип диска
Select Case objDrive.DriveType
Case 0
Cells(intRow, 3) = «Неизвестно»
Case 1
Cells(intRow, 3) = «Съемный»
Case 2
Cells(intRow, 3) = «Жесткий»
Case 3
Cells(intRow, 3) = «Сетевой»
Case 4
Cells(intRow, 3) = «CD-ROM»
Case 5
Cells(intRow, 3) = «RAM»
End Select
' Метка диска
Cells(intRow, 4) = objDrive.VolumeName
' Общий размер
Cells(intRow, 5) = objDrive.TotalSize
' Свободное место
Cells(intRow, 6) = objDrive.AvailableSpace
intRow = intRow + 1
Next
End Sub
После написания кода в окне выбора макросов появится макрос Driveslnf о. В результате его выполнения на текущем рабочем листе будет сформирован список, пример которого показан на рис. 3.39.
Рис. 3.39. Список с информацией о дисках компьютера
Для каждой позиции списка последовательно указывается буква диска, его «готовность к работе» в данный момент, тип диска, общий объем диска и свободное в настоящее время место на нем.
Очевидно, что содержимое данного списка зависит от конфигурации используемого компьютера.
Расчет среднего арифметического
В данном разделе мы рассмотрим небольшой трюк, с помощью которого можно быстро рассчитать среднее значение ячеек, расположенных над активной ячейкой, с отображением результата в активной ячейке.
Как известно, расчет среднего значения можно выполнять штатными средствами Excel – с помощью функции СРЗНАЧ. Однако в некоторых случаях удобнее воспользоваться макросом, код которого представлен в листинге 3.100 (этот код нужно набрать в стандартном модуле редактора VBA).
Sub CalculateAverage()
Dim strFistCell As String
Dim strLastCell As String
Dim strFormula As String
' Условия закрытия процедуры
If ActiveCell.Row = 1 Then Exit Sub
' Определение положения первой и последней ячеек для расчета
strFistCell = ActiveCell.Offset(-1, 0).End(xlUp).Address
strLastCell = ActiveCell.Offset(-1, 0).Address
' Формула для расчета среднего значения
strFormula = "=AVERAGE(" & strFistCell & ":" & strLastCell &
")"
' Ввод формулы в текущую ячейку
ActiveCell.Formula = strFormula
End Sub
В результате выполнения данного макроса в активной ячейке отобразится среднее арифметическое, рассчитанное на основании расположенных выше непустых ячеек; при этом ячейки с данными должны следовать одна за другой, без пробелов. Иначе говоря, если активна ячейка А5, а над ней все ячейки содержат данные, кроме ячейки А2, то среднее арифметическое будет рассчитано на основании данных ячеек A3 и А4 (ячейка А1 в расчете участвовать не будет). Если же пустой является только ячейка А4, то среднее арифметическое в ячейке А5 рассчитано не будет.
Вывод списка доступных шрифтов
При необходимости можно сформировать и вывести на печать список доступных в системе шрифтов. Для этого нужно написать и выполнить следующий макрос (листинг 3.101).
Sub ListOfFonts()
Dim cbrcFonts As CommandBarControl