Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7

• Название: Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
• Анкор: Информатика
• Дата: 16.05.2022
• Размер: 1.27 Mb.
• Имя файла: VBA_v_primerakh.doc
• Тип: Книга; #532661
• страница: 16 из 21

Склонение фамилии, имени и отчества

Листинг 3.85. Склонение ФИО

Public Sub PossessiveCase()

' Склоняем ФИО в родительный падеж

Dim strName1 As String, strName2 As String, strName3 As String

strName1 = dhGetName(ActiveCell, 1) ' Выделяем имя

strName2 = dhGetName(ActiveCell, 2) ' Выделяем фамилию

strName3 = dhGetName(ActiveCell, 3) ' Выделяем отчество

' Если в ячейке менее трех слов - закрытие процедуры

If strName1 = "" Or strName2 = "" Or strName3 = "" Then Exit Sub

' Склоняем

Cells(ActiveCell.Row, ActiveCell.Column) = dhPossessive( _

strName1, strName2, strName3)

End Sub

Public Sub DativeCase()

' Объявление переменных

Dim strName1 As String, strName2 As String, strName3 As String

strName1 = dhGetName(ActiveCell, 1)

strName2 = dhGetName(ActiveCell, 2)

strName3 = dhGetName(ActiveCell, 3)

' Если в ячейке менее трех слов - закрытие процедуры

If Len(strName1) = 0 Or Len(strName2) = 0 Or Len(strName3) = 0 _

Then Exit Sub

Cells(ActiveCell.Row, ActiveCell.Column) = dhDative( _

strName1, strName2, strName3)

End Sub

Function dhPossessive(strName1 As String, strName2 As String, _

strName3 As String) As String

Dim fMan As Boolean

' Определяем, мужские ФИО или женские

fMan = (Right(strName3, 1) = "ч")

' Склонение фамилии в родительный падеж

If Len(strName1) > 0 Then

If fMan Then

' Склонение мужской фамилии

Select Case Right(strName1, 1)

Case "о", "и", "я", "а"

dhPossessive = strName1

Case "й"

dhPossessive = Mid(strName1, 1, Len(strName1) - 2) + "ого"

Case Else

dhPossessive = strName1 + "а"

End Select

Else

' Склонение женской фамилии

Select Case Right(strName1, 1)

Case "о", "и", "б", "в", "г", "д", "ж", "з", "к", "л", _

"м", "н", "п", "р", "с", "т", "ф", "х", "ц", "ч", _

"ш", "щ", "ь"

dhPossessive = strName1

Case "я"

dhPossessive = Mid(strName1, 1, Len(strName1) - 2) & "ой"

Case Else

dhPossessive = Mid(strName1, 1, Len(strName1) - 1) & "ой"

End Select

End If

dhPossessive = dhPossessive & " "

End If

' Склонение имени в родительный падеж

If Len(strName2) > 0 Then

If fMan Then

' Склонение мужского имени

Select Case Right(strName2, 1)

Case "й", "ь"

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & "я"

Case Else

dhPossessive = dhPossessive & strName2 & "а"

End Select

Else

' Склонение женского имени

Select Case Right(strName2, 1)

Case "а"

Select Case Mid(strName2, Len(strName2) - 1, 1)

Case "и", "г"

dhPossessive = dhPossessive & Mid( _

strName2, 1, Len(strName2) - 1) & "и"

Case Else

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & "ы"

End Select

Case "я"

If Mid(strName2, Len(strName2) - 1, 1) = "и" Then

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & "и"

Else

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & "и"

End If

Case "ь"

dhPossessive = dhPossessive & Mid(strName2, _

1, Len(strName2) - 1) & "и"

Case Else

dhPossessive = dhPossessive & strName2

End Select

End If

dhPossessive = dhPossessive & " "

End If

' Склонение отчества в родительный падеж

If Len(strName3) > 0 Then

If fMan Then

dhPossessive = dhPossessive & strName3 & "а"

Else

dhPossessive = dhPossessive & Mid(strName3, 1, _

Len(strName3) - 1) & "ы"

End If

End If

End Function

Function dhDative(strName1 As String, strName2 As String, _

strName3 As String) As String

Dim fMan As Boolean

' Определяем, мужские ФИО или женские

fMan = (Right(strName3, 1) = "ч")

' Склонение фамилии в дательный падеж

If Len(strName1) > 0 Then

If fMan Then

' Склонение мужской фамилии

Select Case Right(strName1, 1)

Case "о", "и", "я", "а"

dhDative = strName1

Case "й"

dhDative = Mid(strName1, 1, Len(strName1) - 2) + "ому"

Case Else

dhDative = strName1 + "у"

End Select

Else

' Склонение женской фамилии

Select Case Right(strName1, 1)

Case "о", "и", "б", "в", "г", "д", "ж", "з", "к", "л", _

"м", "н", "п", "р", "с", "т", "ф", "х", "ц", "ч", "ш", _

"щ", "ь"

dhDative = strName1

Case "я"

dhDative = Mid(strName1, 1, Len(strName1) - 2) & "ой"

Case Else

dhDative = Mid(strName1, 1, Len(strName1) - 1) & "ой"

End Select

End If

dhDative = dhDative & " "

End If

' Склонение имени в дательный падеж

If Len(strName2) > 0 Then

If fMan Then

' Склонение мужского имени

Select Case Right(strName2, 1)

Case "й", "ь"

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & "ю"

Case Else

dhDative = dhDative & strName2 & "у"

End Select

Else

' Склонение женского имени

Select Case Right(strName2, 1)

Case "а", "я"

If Mid(strName2, Len(strName2) - 1, 1) = "и" Then

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & "и"

Else

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & "е"

End If

Case "ь"

dhDative = dhDative & Mid(strName2, 1, _

Len(strName2) - 1) & "и"

Case Else

dhDative = dhDative & strName2

End Select

End If

dhDative = dhDative & " "

End If

' Склонение отчества в дательный падеж

If Len(strName3) > 0 Then

If fMan Then

dhDative = dhDative & strName3 & "у"

Else

dhDative = dhDative & Mid(strName3, 1, Len(strName3) - 1) & "е"

End If

End If

End Function

Function dhGetName(strString As String, intNum As Integer)

' Функция возвращает слово с номером intNum во входной строке _

strString

Dim strTemp As String

Dim intWord As Integer

Dim intSpace As Integer

' Удаление пробелов по краям строки

strTemp = Trim(strString)

' Просмотр строки (до слова с нужным номером)

For intWord = 1 To intNum - 1

' Поиск следующего пробела

intSpace = InStr(strTemp, " ")

If intSpace = 0 Then

' Строка закончилась

intSpace = Len(strTemp)

End If

' Строка strTemp теперь начинается со слова с номером intWord

strTemp = Trim(Right(strTemp, Len(strTemp) - intSpace))

Next intWord

' Выделение нужного слова (по пробелу после него)

intSpace = InStr(strTemp, " ")

If intSpace = 0 Then

intSpace = Len(strTemp)

End If

dhGetName = Trim(Left(strTemp, intSpace))

End Function

Получение информации об используемом принтере

Листинг 3.86. Информация о принтере

' Объявление API-функции

Declare Function GetProfileStringA Lib "kernel32" _

(ByVal lpAppName As String, ByVal lpKeyName As String, _

ByVal lpDefault As String, ByVal lpReturnedString As _

String, ByVal nSize As Long) As Long

Sub Принтер()

Dim strFullInfo As String * 255 ' Буфер для API-функции

Dim strInfo As String ' Строка с полной информацией

Dim strPrinter As String ' Название принтера

Dim strDriver As String ' Драйвер принтера

Dim strPort As String ' Порт принтера

Dim strMessage As String

Dim intPrinterEndPos As Integer

Dim intDriverEndPos As Integer

' Заполнение буфера пробелами

strFullInfo = Space(255)

' Получение полной информации о принтере

Call GetProfileStringA("Windows", "Device", "", strFullInfo, 254)

' Удаление лишних символов из конца возвращенной строки

' Строка strInfo имеет формат <имя_принтера>,<драйвер>,<порт>:

strInfo = Trim(strFullInfo)

' Поиск запятых в строке (окончаний названий принтера и драйвера)

intPrinterEndPos = Application.Find(",", strInfo, 1)

intDriverEndPos = Application.Find(",", strInfo, intPrinterEndPos + 1)

' Определение названия принтера

strPrinter = Left(strInfo, intPrinterEndPos - 1)

' Определение драйвера

strDriver = Mid(strInfo, intPrinterEndPos + 1, intDriverEndPos _

- intPrinterEndPos - 1)

' Определение порта (его название заканчивается символом ":")

strPort = Mid(strInfo, intDriverEndPos + 1, InStr(1, strInfo, ":") _

- intDriverEndPos - 1)

' Формирование информационного сообщения

strMessage = "Принтер:" & Chr(9) & strPrinter & Chr(13)

strMessage = strMessage & "Драйвер:" & strDriver & Chr(13)

strMessage = strMessage & "strPort:" & Chr(9) & strPort

' Вывод информационного сообщения

MsgBox strMessage, vbInformation, "Сведения о принтере по умолчанию"

End Sub

Вывод текущей даты и времени

Листинг 3.87. Сообщение о дате и времени

Sub TimeAndDate()

Dim strDate As String, strTime As String

Dim strGreeting As String

Dim strUserName As String

Dim intSpacePos As Integer

strDate = Format(Date, "Long Date")

strTime = Format(Time, "Medium Time")

' Приветствие - в зависимости от времени суток

If Time < TimeValue("12:00") Then

strGreeting = "Доброе утро, "

ElseIf Time < TimeValue("17:00") Then

strGreeting = "Добрый день, "

Else

strGreeting = "Добрый вечер, "

End If

' В приветствие добавляется имя текущего пользователя

strUserName = Application.UserName

intSpacePos = InStr(1, strUserName, " ", 1)

' Управление ситуацией, когда в имени нет пробела

If intSpacePos = 0 Then intSpacePos = Len(strUserName)

strGreeting = strGreeting & Left(strUserName, intSpacePos)

' Вывод на экран информационного сообщения о дате и времени

MsgBox strDate & vbCrLf & strTime, vbOKOnly, strGreeting

End Sub

Автоматическое создание документов Word на основе табличных данных Excel

Листинг 3.88. Создание документов Word на основе таблицы Excel

Sub ReportToWord()

Dim intReportCount As Integer ' Количество сообщений

Dim strForWho As String ' Получатель сообщения

Dim strSum As String ' Сумма за товар

Dim strProduct As String ' Название товара

Dim strOutFileName As String ' Имя файла для сохранения сообщения

Dim strMessage As String ' Текст дополнительного сообщения

Dim rgData As Range ' Обрабатываемые ячейки

Dim objWord As Object

Dim i As Integer

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

Set objWord = CreateObject("Word.Application")

' Информация с рабочего листа

Set rgData = Range("A1")

strMessage = Range("E6")

' Просмотр записей на листе Лист1

intReportCount = Application.CountA(Range("A:A"))

For i = 1 To intReportCount

' Динамические сообщения в строке состояния

Application.StatusBar = "Создание сообщения " & i

' Назначение данных переменным

strForWho = rgData.Cells(i, 1).Value

strProduct = rgData.Cells(i, 2).Value

strSum = Format(rgData.Cells(i, 3).Value, "#,000")

' Имя файла для сохранения отчета

strOutFileName = ThisWorkbook.path & "\" & strForWho & ".doc"

' Передача команд в Word

With objWord

.Documents.Add

With .Selection

' Заголовок сообщения

.Font.Size = 14

.Font.Bold = True

.ParagraphFormat.Alignment = 1

.TypeText Text:="О Т Ч Е Т"

' Дата

.TypeParagraph

.TypeParagraph

.Font.Size = 12

.ParagraphFormat.Alignment = 0

.Font.Bold = False

.TypeText Text:="Дата:" & vbTab & _

Format(Date, "mmmm d, yyyy")

' Получатель сообщения

.TypeParagraph

.TypeText Text:="Кому: менеджеру " & vbTab & strForWho

' Отправитель

.TypeParagraph

.TypeText Text:="От:" & vbTab & Application.UserName

' Сообщение

.TypeParagraph

.TypeParagraph

.TypeText strMessage

.TypeParagraph

.TypeParagraph

' Название товара

.TypeText Text:="Продано товара:" & vbTab & strProduct

.TypeParagraph

' Сумма за товар

.TypeText Text:="На сумму:" & vbTab & _

Format(strSum, "$#,##0")

End With

' Сохранение документа

.ActiveDocument.SaveAs FileName:=strOutFileName

End With

Next i

' Удаление объекта Word

objWord.Quit

Set objWord = Nothing

' Обновление строки состояния

Application.StatusBar = False

' Вывод на экран информационного сообщения

MsgBox intReportCount & " заметки создано и сохранено в папке " _

& ThisWorkbook.path

End Sub

Создание списка панелей инструментов и контекстных меню

Листинг 3.89. Список панелей инструментов и контекстных меню

Sub ListOfMenues()

Dim intRow As Integer ' Хранит текущую строку

Dim cbrBar As CommandBar

' Очистка всех ячеек текущего листа

Cells.Clear

intRow = 1 ' Начинаем запись с первой строки

' Просматриваем список панелей инструментов и меню _

и записываем информацию о каждом элементе в таблицу

For Each cbrBar In CommandBars

' Порядковый номер

Cells(intRow, 1) = cbrBar.Index

' Название

Cells(intRow, 2) = cbrBar.Name

' Тип

Select Case cbrBar.Type

Case msoBarTypeNormal

Cells(intRow, 3) = "Панель инструментов"

Case msoBarTypeMenuBar

Cells(intRow, 3) = "Строка меню"

Case msoBarTypePopup

Cells(intRow, 3) = "Контекстное меню"

End Select

' Встроенный элемент или созданный пользователем

Cells(intRow, 4) = cbrBar.BuiltIn

' Переходим на следующую строку

intRow = intRow + 1

Next

End Sub

Создание списка пунктов главного меню Excel

Листинг 3.90. Список содержимого главного меню

Sub ListOfMenues()

Dim intRow As Integer ' Текущая строка, куда идет запись

Dim cbrcMenu As CommandBarControl ' Главное меню

Dim cbrcSubMenu As CommandBarControl ' Подменю

Dim cbrcSubSubMenu As CommandBarControl ' Подменю в подменю

' Очищаем ячейки текущего листа

Cells.Clear

' Начинаем запись с первой строки

intRow = 1

' Просматриваем все элементы строки меню

On Error Resume Next ' Игнорируем ошибки

For Each cbrcMenu In CommandBars(1).Controls

' Просматриваем элементы выпадающего меню cbrcMenu

For Each cbrcSubMenu In cbrcMenu.Controls

' Просматриваем элементы подменю cbrcSubMenu

For Each cbrcSubSubMenu In cbrcSubMenu.Controls

' Выводим название главного меню

Cells(intRow, 1) = cbrcMenu.Caption

' Выводим название подменю

Cells(intRow, 2) = cbrcSubMenu.Caption

' Выводим название вложенного подменю

Cells(intRow, 3) = cbrcSubSubMenu.Caption

' Переходим на следующую строку

intRow = intRow + 1

Next cbrcSubSubMenu

Next cbrcSubMenu

Next cbrcMenu

End Sub

Создание списка пунктов контекстных меню

Листинг 3.91. Список содержимого контекстных меню

Sub ListOfContextMenues()

Dim intRow As Long

Dim intControl As Integer

Dim cbrBar As CommandBar

' Очистка ячеек активного листа

Cells.Clear

' Начинаем вывод с первой строки

intRow = 1

' Просмотр списка контекстных меню и вывод информации о них

For Each cbrBar In CommandBars

If cbrBar.Type = msoBarTypePopup Then

' Порядковый номер

Cells(intRow, 1) = cbrBar.Index

' Название

Cells(intRow, 2) = cbrBar.Name

' Просмотр всех элементов контекстного меню и вывод _

названий этих элементов в ячейки текущей строки

For intControl = 1 To cbrBar.Controls.Count

Cells(intRow, intControl + 2) = _

cbrBar.Controls(intControl).Caption

Next intControl

' Переход на следующую строку таблицы

intRow = intRow + 1

End If

Next cbrBar

' Делаем ширину ячеек таблицы оптимальной для просмотра

Cells.EntireColumn.AutoFit

End Sub

Отображение панели инструментов при определенном условии

Листинг 3.92. Код в модуле рабочего листа

Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

' Проверка условия отображения

If Union(Target, Range("A1:D5")).Address = _

Range("A1:D5").Address Then

' Условие выполнено - можно показывать панель

CommandBars("AutoSense").Visible = True

Else

' Условие не выполнено - панель нужно скрыть

CommandBars("AutoSense").Visible = False

End If

End Sub

Листинг 3.93. Код в стандартном модуле

Sub CreatePanel()

Dim cbrBar As CommandBar

Dim button As CommandBarButton

Dim i As Integer

' Удаление одноименной панели (при ее наличии)

On Error Resume Next

CommandBars("AutoSense").Delete

On Error GoTo 0

' Создание панели инструментов

Set cbrBar = CommandBars.Add

' Создание кнопок и их настройка

For i = 1 To 4

Set button = cbrBar.Controls.Add(msoControlButton)

With button

.OnAction = "ButtonClick" & i

.FaceId = i + 37

End With

Next i

cbrBar.Name = "AutoSense"

End Sub

Sub ButtonClick3()

' Перемещение вниз

On Error Resume Next

ActiveCell.Offset(1, 0).Activate

End Sub

Sub ButtonClick1()

' Перемещение вверх

On Error Resume Next

ActiveCell.Offset(-1, 0).Activate

End Sub

Sub ButtonClick2()

' Перемещение вправо

On Error Resume Next

ActiveCell.Offset(0, 1).Activate

End Sub

Sub ButtonClick4()

' Перемещение влево

On Error Resume Next

ActiveCell.Offset(0, -1).Activate

End Sub

Скрытие и отображение панелей инструментов

Листинг 3.94. Управление отображением панелей инструментов

Sub HidePanels()

Dim cbrBar As CommandBar

Dim intRow As Integer ' Номер текущей строки листа

' Отключение обновления экрана

Application.ScreenUpdating = False

' Подготовка к сохранению

Cells.Clear

' Скрытие видимых панелей и сохранение их названий

intRow = 1 ' Запись имен с первой строки

For Each cbrBar In CommandBars

If cbrBar.Type = msoBarTypeNormal Then

If cbrBar.Visible Then

cbrBar.Visible = False

Cells(intRow, 1) = cbrBar.Name

intRow = intRow + 1

End If

End If

Next

' Включение обновления экрана

Application.ScreenUpdating = True

End Sub

Sub ShowPanels()

Dim cell As Range ' Текущая ячейка листа

' Отключение обновления экрана

Application.ScreenUpdating = False

' Отображение скрытых панелей

On Error Resume Next

For Each cell In Range("A:A").SpecialCells( _

xlCellTypeConstants)

CommandBars(cell.Value).Visible = True

Next cell

' Включение обновления экрана

Application.ScreenUpdating = True

End Sub

Создание меню на основе данных рабочего листа

Листинг 3.95. Код в модуле ЭтаКнига

Sub Workbook_Open()

' Создание меню

Call CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

' Удаление меню перед закрытием книги

Call DeleteCustomMenu

End Sub

Листинг 3.96. Код в стандартном модуле

Sub CreateMenu()

Dim sheet As Worksheet ' Лист с описанием меню

Dim intRow As Integer ' Считываемая строка

Dim cbrpBar As CommandBarPopup ' Выпадающее меню

Dim objNewItem As Object ' Элемент меню cbrpBar

Dim objNewSubItem As Object ' Элемент подменю objNewItem

Dim intMenuLevel As Integer ' Уровень вложенности пункта меню

Dim strCaption As String ' Название пункта меню

Dim strAction As String ' Макрос пункта меню

Dim fIsDevider As Boolean ' Нужен разделитель

Dim intNextLevel As Integer ' Уровень вложенности следующего _

пункта меню

Dim strFaceID As String ' Номер значка пункта меню

' Расположение данных для меню

Set sheet = ThisWorkbook.Sheets("ЛистМеню")

' Удаление одноименного меню (при его наличии)

Call DeleteMenu

' Данные считываем со второй строки

intRow = 2

' Добавление меню

Do Until IsEmpty(sheet.Cells(intRow, 1))

' Считываем информацию о пункте меню

With sheet

' Уровень вложенности

intMenuLevel = .Cells(intRow, 1)

' Название

strCaption = .Cells(intRow, 2)

' Название макроса для меню

strAction = .Cells(intRow, 3)

' Нужен ли разделитель перед меню?

fIsDevider = .Cells(intRow, 4)

' Номер стандартного значка (если значок нужен)

strFaceID = .Cells(intRow, 5)

' Уровень вложенности следующего меню

intNextLevel = .Cells(intRow + 1, 1)

End With

' Создаем меню в зависимости от уровня его вложенности

Select Case intMenuLevel

Case 1

' Создаем меню

Set cbrpBar = Application.CommandBars(1). _

Controls.Add(Type:=msoControlPopup, _

Before:=strAction, _

Temporary:=True)

cbrpBar.Caption = strCaption

Case 2

' Создаем элемент меню

If intNextLevel = 3 Then

' Следующий элемент вложен в создаваемый, то есть _

создаем раскрывающееся подменю

Set objNewItem = _

cbrpBar.Controls.Add(Type:=msoControlPopup)

Else

' Создаем команду меню

Set objNewItem = _

cbrpBar.Controls.Add(Type:=msoControlButton)

objNewItem.OnAction = strAction

End If

' Установка названия нового пункта меню

objNewItem.Caption = strCaption

' Установка значка нового пункта меню (если нужно)

If strFaceID <> "" Then

objNewItem.FaceId = strFaceID

End If

' Если нужно, то добавим разделитель

If fIsDevider Then

objNewItem.BeginGroup = True

End If

Case 3

' Создание элемента подменю

Set objNewSubItem = _

objNewItem.Controls.Add(Type:=msoControlButton)

' Установка его названия

objNewSubItem.Caption = strCaption

' Назначение макроса (или команды)

objNewSubItem.OnAction = strAction

' Установка значка (если нужно)

If strFaceID <> "" Then

objNewSubItem.FaceId = strFaceID

End If

' Если нужно, то добавим разделитель

If fIsDevider Then

objNewSubItem.BeginGroup = True

End If

End Select

' Переход на следующую строку таблицы

intRow = intRow + 1

Loop

End Sub

Sub DeleteMenu()

Dim sheet As Worksheet ' Лист с описанием меню

Dim intRow As Integer ' Считываемая строка

Dim strCaption As String ' Название меню

Set sheet = ThisWorkbook.Sheets("ЛистМеню")

' Данные начинаются со второй строки

intRow = 2

' Считываем данные, пока есть значения в столбце "A", _

и удаляем созданные ранее меню (с уровнем вложенности 1)

On Error Resume Next

Do Until IsEmpty(sheet.Cells(intRow, 1))

If sheet.Cells(intRow, 1) = 1 Then

strCaption = sheet.Cells(intRow, 2)

Application.CommandBars(1).Controls(strCaption).Delete

End If

intRow = intRow + 1

Loop

On Error GoTo 0

End Sub

Создание контекстного меню

Листинг 3.97. Код в модуле рабочего листа

Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _

Cancel As Boolean)

' Проверка, попадает ли выделенная ячейка в диапазон

If Union(Target.Range("A1"), Range("A2:D5")).Address = _

Range("A2:D5").Address Then

' Показываем свое контекстное меню

CommandBars("MyContextMenu").ShowPopup

Cancel = True

End If

End Sub

Листинг 3.98. Код в модуле ЭтаКнига

Sub Workbook_Open()

' Создание контекстного меню при открытии книги

Call CreateCustomContextMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

' Удаление меню при закрытии книги

Call DeleteCustomContextMenu

End Sub

Листинг 3.99. Код в стандартном модуле

Sub CreateCustomContextMenu()

' Удаление одноименного меню

Call DeleteCustomContextMenu

' Создание меню

With CommandBars.Add("MyContextMenu", msoBarPopup, , True).Controls

' Создание и настройка кнопок меню

' Кнопка "Числовой формат"

With .Add(msoControlButton)

.Caption = "&Числовой формат..."

.OnAction = "ShowFormatNumber"

.FaceId = 1554

End With

' Кнопка "Выравнивание"

With .Add(msoControlButton)

.Caption = "&Выравнивание..."

.OnAction = "ShowFormatAlignment"

.FaceId = 217

End With

' Кнопка "Шрифт"

With .Add(msoControlButton)

.Caption = "&Шрифт..."

.OnAction = "ShowFormatFont"

.FaceId = 291

End With

' Кнопка "Границы"

With .Add(msoControlButton)

.Caption = "&Границы..."

.OnAction = "ShowFormatBorder"

.FaceId = 149

.BeginGroup = True

End With

' Кнопка "Узор"

With .Add(msoControlButton)

.Caption = "&Узор..."

.OnAction = "ShowFormatPatterns"

.FaceId = 1550

End With

' Кнопка "Защита"

With .Add(msoControlButton)

.Caption = "&Защита..."

.OnAction = "ShowFormatProtection"

.FaceId = 2654

End With

End With

End Sub

Sub DeleteCustomContextMenu()

' Удаление меню

On Error Resume Next

CommandBars("MyContextMenu").Delete

End Sub

Sub ShowFormatNumber()

' Число

Application.Dialogs(xlDialogFormatNumber).Show

End Sub

Sub ShowFormatAlignment()

' Выравнивание

Application.Dialogs(xlDialogAlignment).Show

End Sub

Sub ShowFormatFont()

' Шрифт

Application.Dialogs(xlDialogFormatFont).Show

End Sub

Sub ShowFormatBorder()

' Граница

Application.Dialogs(xlDialogBorder).Show

End Sub

Sub ShowFormatPatterns()

' Вид (Узор)

Application.Dialogs(xlDialogPatterns).Show

End Sub

Sub ShowFormatProtection()

' Защита

Application.Dialogs(xlDialogCellProtection).Show

End Sub

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

Листинг 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

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

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

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

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

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

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

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

Листинг 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. Обработка текстовых файлов

Sub ImportTextFiles()

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

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

With fsSearch

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

.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)"

End Sub

Запуск таблицы символов из Excel

Листинг 3.106. Вызов таблицы символов

Sub ShowSymbolTable()

On Error Resume Next

' Запуск Charmap.exe - таблицы символов

Shell "Charmap.exe", vbNormalFocus

If Err <> 0 Then

MsgBox "Невозможно запустить таблицу символов.", vbCritical

End If

End Sub

Листинг 3.107. Таблица символов

' Декларация API-функций:

' для открытия процесса

Declare Function OpenProcess Lib "kernel32" _

(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _

ByVal dwProcessId As Long) As Long

' для получения кода завершения процесса

Declare Function GetExitCodeProcess Lib "kernel32" _

(ByVal hProcess As Long, lpExitCode As Long) As Long

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

Declare Function CloseHandle Lib "kernel32" _

(hProcess) As Long

Sub ShowSymbolTable1()

Dim lProcessID As Long

Dim hProcess As Long

Dim lExitCode As Long

On Error Resume Next

' Запуск таблицы символов (Charman.exe). Функция возвращает _

идентификатор созданного процесса

lProcessID = Shell("Charmap.exe", 1)

If Err <> 0 Then

MsgBox "Нельзя запустить Charman.exe", vbCritical, "Ошибка"

Exit Sub

End If

' Открытие процесса по идентификатору (lProcessID). Функция _

возвращает дескриптор процесса (handle)

hProcess = OpenProcess(&H400, False, lProcessID)

' Ждем, пока процесс завершится, для этого периодически _

получаем код завершения процесса (пока Charman.exe исполняется, _

функция GetExitCodeProcess возвращает &H103)

Do

GetExitCodeProcess hProcess, lExitCode

DoEvents

Loop While lExitCode = &H103

' Закрытие процесса

CloseHandle (hProcess)

' Вывод на экран информационного сообщения

MsgBox "Charmap.exe завершает свою работу"

End Sub

Создание раскрывающегося списка

Листинг 3.108. Создание панели со списком

Sub CreatePanel()

Dim i As Integer

On Error Resume Next

' Удаление одноименной панели (если есть)

CommandBars("Список месяцев").Delete

On Error GoTo 0

' Создание панели "Список месяцев"

With CommandBars.Add

.Name = "Список месяцев"

' Создание списка месяцев

With .Controls.Add(Type:=msoControlDropdown)

' Настройка (имя, макрос, стиль)

.Caption = "DateDD"

.OnAction = "SetMonth"

.Style = msoButtonAutomatic

' Добавление в список названий месяцев

For i = 1 To 12

.AddItem Format(DateSerial(1, i, 1), "mmmm")

Next i

' Выделение первого месяца

.ListIndex = 1

End With

' Показываем созданную панель

.Visible = True

End With

End Sub

Sub SetMonth()

' Перенос названия выделенного месяца в ячейку

On Error Resume Next

With CommandBars("Список месяцев").Controls("DateDD")

ActiveCell.Value = .List(.ListIndex)

End With

End Sub

Добавление команды в меню

Добавление команды в меню Сервис

Листинг 3.109. Новая команда в меню Сервис

Sub AddMenuItem()

Dim cbrpMenu As CommandBarPopup

' Удаление аналогичной команды (при ее наличии)

Call DeleteMenuItem

' Получение доступа к меню "Сервис"

Set cbrpMenu = CommandBars(1).FindControl(ID:=30007)

If cbrpMenu Is Nothing Then

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

MsgBox "Невозможно добавить элемент."

Exit Sub

Else

' Добавление новой команды в меню

With cbrpMenu.Controls.Add(Type:=msoControlButton)

' Название команды

.Caption = "Очистить в&се, кроме формул"

' Значок

.FaceId = 348

' Сочетание клавиш (только надпись на кнопке)

.ShortcutText = "Ctrl+Shift+C"

' Сопоставленный макрос

.OnAction = "ExecuteCommand"

' Добавление разделителя перед командой

.BeginGroup = True

End With

End If

' Сопоставление с макросом сочетания клавиш Ctrl+Shift+C

Application.MacroOptions _

Macro:="ExecuteCommand", _

HasShortcutKey:=True, _

ShortcutKey:="C"

End Sub

Sub ExecuteCommand()

' Очистка содержимого всех ячеек (кроме формул)

On Error Resume Next

Cells.SpecialCells(xlCellTypeConstants, 23).ClearContents

End Sub

Sub DeleteMenuItem()

' Удаление команды из меню

On Error Resume Next

CommandBars(1).FindControl(ID:=30007). _

Controls("Очистить в&се, кроме формул").Delete

End Sub

Добавление команды в меню Вид

Листинг 3.110. Код в стандартном модуле

Dim AppObject As New Class1

Sub AddCommand()

Dim cbrpBar As CommandBarPopup

' Удаление аналогичной команды (при ее наличии)

Call DeleteCommand

' Получение доступа к меню "Вид"

Set cbrpBar = CommandBars(1).FindControl(ID:=30004)

If cbrpBar Is Nothing Then

' Не удалось получить доступ к меню

MsgBox "Невозможно добавить элемент меню."

Exit Sub

Else

' Добавление команды

With cbrpBar.Controls.Add(Type:=msoControlButton)

.Caption = "&Линии сетки"

.OnAction = "GhangeGridlinesState"

End With

End If

' Даем объекту AppObject обрабатывать события

Set AppObject.AppEvents = Application

End Sub

Sub DeleteCommand()

' Удаление каманды из меню (если она там есть)

On Error Resume Next

CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки").Delete

End Sub

Sub GhangeGridlinesState()

' Изменение состояния отображения линий сетки _

на противоположное (если нет - покажем, если есть - скроем)

If TypeName(ActiveSheet) = "Worksheet" Then

ActiveWindow.DisplayGridlines = _

Not ActiveWindow.DisplayGridlines

' Установка или снятие флажка в меню

Call CheckGridlines

End If

End Sub

Sub CheckGridlines()

Dim button As CommandBarButton

On Error Resume Next

' Поиск команды "Линии сетки" в меню "Вид"

Set button = CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки")

' Изменение состояния флажка на противоположное

If ActiveWindow.DisplayGridlines Then

' Установка

button.State = msoButtonDown

Else

' Снятие

button.State = msoButtonUp

End If

End Sub

Листинг 3.111. Код в модуле класса

Public WithEvents AppEvents As Application

' Обработка события активации листа

Sub AppEvents_SheetActivate(ByVal Sh As Object)

Call CheckGridlines

End Sub

' Обработка события активации книги

Sub AppEvents_WorkbookActivate(ByVal Wb As Excel.Workbook)

Call CheckGridlines

End Sub

' Обработка события активации окна

Sub AppEvents_WindowActivate _

(ByVal Wb As Workbook, ByVal Wn As Window)

Call CheckGridlines

End Sub