Получение информации о состоянии дисков

Листинг 3.102.Просмотр информации о дисках компьютера

Sub DrivesInfo()

Dim objFileSysObject As Object ' Объект для работы _

с файловой системой

DimobjDriveAsObject' Анализируемый диск

DimintRowAsInteger' Заполняемая строка листа

' Создание объекта для работы с файловой системой

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

EndSub

Расчет среднего арифметического

Листинг 3.103.Расчет среднего значения

SubCalculateAverage()

Dim strFistCell As String

Dim strLastCell As String

DimstrFormulaAsString

' Условия закрытия процедуры

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

Вывод списка доступных шрифтов

Листинг 3.104. Список шрифтов

Sub ListOfFonts()

Dim cbrcFonts As CommandBarControl

Dim cbrBar As CommandBar

Dim i As Integer

' Получение доступа к списку шрифтов (элемент управления в виде _

раскрывающегося списка на панели инструментов "Форматирование")

Set cbrcFonts = Application.CommandBars("Formatting"). _

FindControl(ID:=1728)

If cbrcFonts Is Nothing Then

' Панель "Форматирование" не открыта - откроем ее

Set cbrBar = Application.CommandBars.Add

Set cbrcFonts = cbrBar.Controls.Add(ID:=1728)

End If

' Подготовка к выводу шрифтов (очистка ячеек)

Range("A:A").ClearContents

' Вывод списка шрифтов в столбец "A" текущего листа

For i = 0 To cbrcFonts.ListCount - 1

Cells(i + 1, 1) = cbrcFonts.List(i + 1)

Next i

' Закрытие панели инструментов "Форматирование", если мы были _

вынуждены ее открывать

On Error Resume Next

cbrBar.Delete

End Sub

Обработка сразу нескольких внешних файлов

Листинг 3.105.Обработка текстовых файлов

SubImportTextFiles()

Dim fsSearch As FileSearch

Dim strFileName As String

Dim strPath As String

Dim i As Integer

' Задание пути и возможного имени файла

strFileName = ThisWorkbook.path & "\"

strPath = "text??.txt"

' Создание объекта FileSearch

Set fsSearch = Application.FileSearch

' Настройка объекта для поиска

WithfsSearch

' Маска для поиска

.LookIn=strFileName

' Путь для поиска

.FileName=strPath

' Поиск всех файлов, удовлетворяющих маске

.Execute

' Выход, если файлы не существуют

If .FoundFiles.Count = 0 Then

MsgBox "Файлы не обнаружены"

Exit Sub

End If

End With

' Обработка найденных файлов

For i = 1 To fsSearch.FoundFiles.Count

Call ImportTextFile(fsSearch.FoundFiles(i))

Next i

End Sub

Sub ImportTextFile(FileName As String)

' Импорт файла

Workbooks.OpenText FileName:=FileName, _

Origin:=xlWindows, _

StartRow:=1, _

DataType:=xlFixedWidth, _

FieldInfo:= _

Array(Array(0, 1), Array(3, 1), Array(12, 1))

' Ввод формул суммирования

Range("D1").Value= "A"

Range("D2").Value = "B"

Range("D3").Value = "C"

Range("E1:E3").Formula = "=COUNTIF(B:B,D1)"

Range("F1:F3").Formula = "=SUMIF(B:B,D1,C:C)"

EndSub