Текст книги "Excel. Трюки и эффекты"

В данном подразделе мы создадим пользовательское меню, которое будет включать в себя меню Файл (это меню будет соответствовать стандартному меню Файл из Excel более ранних версий) и меню Дополнительно.

Для реализации поставленной задачи необходимо в стандартном модуле редактора VBA написать код, представленный в листинге 3.81.

Листинг 3.81. Создание пользовательского меню

Sub CreateMenu()

Dim cbrMenu As CommandBar

Dim cbrcNewMenu As CommandBarControl

' Удаление меню, если оно уже есть

Call DeleteMenu

' Добавление строки пользовательского меню

Set cbrMenu = CommandBars.Add(MenuBar:=True)

With cbrMenu

.Name = «Моя строка меню»

.Visible = True

End With

' Копирование стандартного меню «Файл»

CommandBars(«Worksheet Menu Bar»).FindControl(ID:=30002).Copy _

CommandBars(«Моя строка меню»)

' Добавление нового меню – «Дополнительно»

Set cbrcNewMenu = cbrMenu.Controls.Add(msoControlPopup)

cbrcNewMenu.Caption = «&Дополнительно»

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

With cbrcNewMenu.Controls.Add(msoControlButton)

.Caption = «&Восстановить обычную строку меню»

.OnAction = «DeleteMenu»

End With

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

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

.Caption = «&Справка»

End With

End Sub

Sub DeleteMenu()

' Пытаемся удалить меню (успешно, если оно ранее создано)

On Error Resume Next

CommandBars(«Моя строка меню»).Delete

On Error GoTo 0

End Sub

В результате написания данного кода будет создан макрос CreateMenu. При его выполнении на вкладке Надстройки появится пользовательское меню, включающее в себя пункты Файл (этот пункт будет соответствовать стандартному меню Файл из Excel более ранниз версий) и Дополнительно. С помощью команды Дополнительно → Восстановить обычную строку меню созданное меню будет удалено. Команда Дополнительно → Справка имеет чисто демонстрационную функцию.

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

Трюк, который мы рассмотрим в данном разделе, удобно применять при работе со списками ФИО. С его помощью можно быстро переводить требуемые ФИО в родительный или дательный падеж. Чтобы достичь подобного эффекта, следует воспользоваться макросом, код которого приведен в листинге 3.82 (данный код записывается в стандартном модуле).

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

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 "о", "и", "я", "а"

dhPossess ive = 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 The

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

Чтобы ФИО отобразились в родительном падеже, следует установить курсор в ячейку с этими ФИО и запустить макрос PossessiveCase; в дательном падеже – макрос DativeCase (после написания кода эти макросы будут доступны в окне выбора макросов).

Внимание!

Для реализации трюка необходимо соблюдать условие – ячейка должна содержать не менее трех слов. В противном случае операция выполнена не будет.

Следует учитывать, что в ячейке сначала должна следовать фамилия, за ней – имя, и затем – отчество.

Данный макрос не всегда способен корректно обрабатывать сложные имена и фамилии.

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

С помощью небольшого макроса можно вывести на экран информацию об используемом принтере. Код макроса записывается в стандартном модуле редактора VBA и выглядит следующим образом (листинг 3.83).

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

' Объявление 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

В данном примере для получения информации о принтере используется API-функция GetProf ileStringA. Эта функция возвращает в строку-буфер strFullInf о информацию в виде <имяпринтера>, <драйвер>, <порт>:.

После запуска данного макроса на экран выводится окно Сведения о принтере по умолчанию (название окна можно корректировать по своему усмотрению путем внесения соответствующих изменений в код макроса), в котором будет показана марка принтера, а также его драйвер и порт.

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

Применив несложный трюк, можно в любой момент вывести на экран окно с информацией о текущей дате и времени. Для достижения такого эффекта достаточно написать и запустить макрос, код которого выглядит следующим образом (листинг 3.84).

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

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

В данном разделе мы рассмотрим трюк, с помощью которого можно автоматически создавать текстовые документы Word на основе данных, хранящихся в таблице Excel. Это бывает необходимо, например, для быстрого формирования текстовых отчетов, в которых должны фигурировать табличные данные. Использование этого приема мы рассмотрим на конкретном примере.

Предположим, что у нас есть следующие данные о продажах по регионам (рис. 3.31).

Внимание!

При изучении данного раздела следует обращать внимание на расположение данных на рабочем листе (то есть на координаты задействованных ячеек).

Для автоматического создания отчетов на основании приведенных данных следует в стандартном модуле редактора VBA написать код, приведенный в листинге 3.85.

Рис. 3.31. Данные о продажах

Листинг 3.85. Создание документов 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

В результате написания кода в окне выбора макросов станет доступным макрос ReportToWord. После его запуска начнется формирование отчетов (информация о состоянии процесса будет отображаться в строке состояния). По окончании процесса на экране отобразится окно с сообщением о том, что документы сформированы и помещены в ту папку, в которой хранится текущая рабочая книга. В рассматриваемом примере будут созданы три документа с именами Магазин 1.doc, Магазин 2.doc и Магазин 3.doc. Содержимое документа Магазин 1. doc показано на рис. 3.32 (другие документы выглядят аналогичным образом).

В рассматриваемом примере Lesha – это имя пользователя, который создал документ. Очевидно, что в результате внесения соответствующих изменений в код макроса форму создаваемого отчета можно корректировать по своему усмотрению.

Рис. 3.32. Документ Word, созданный на основе данных таблицы Excel

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

При необходимости можно сформировать на рабочем листе список доступных панелей инструментов и контекстных меню. Для этого достаточно написать (в стандартном модуле редактора VBA) и запустить на выполнение макрос, код которого приведен в листинге 3.86.

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

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

Результат выполнения данного макроса (после написания кода он будет доступен в окне списка макросов) показан на рис. 3.33.

Рис. 3.33. Фрагмент списка панелей инструментов и меню

Данный список выводится на активном рабочем листе.

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

Подобным образом можно сформировать список подменю и команд, входящих в главное меню (которое существовало в более ранних версиях программы). Для этого в стандартном модуле VBA необходимо написать следующий код (листинг 3.87).

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

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

После запуска макроса ListOfMenues (этот макрос появится в окне выбора макросов после написания приведенного выше кода) список подменю и команд главного меню будет сформирован на текущем рабочем листе.

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

Чтобы вывести аналогичный список содержимого контекстных меню программы, нужно написать и выполнить макрос, код которого приведен в листинге 3.88.

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

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

Сформированный в результате выполнения данного макроса список будет расположен на текущем рабочем листе.