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

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

SubShowSymbolTable()

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)

IfErr<> 0Then

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

ExitSub

EndIf

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

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

hProcess = OpenProcess(&H400, False, lProcessID)

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

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

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

Do

GetExitCodeProcesshProcess,lExitCode

DoEvents

LoopWhilelExitCode= &H103

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

CloseHandle(hProcess)

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

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

EndSub

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

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

SubCreatePanel()

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

Nexti

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

.ListIndex= 1

EndWith

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

.Visible = True

End With

End Sub

SubSetMonth()

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

On Error Resume Next

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

ActiveCell.Value = .List(.ListIndex)

End With

EndSub

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

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

SubAddMenuItem()

DimcbrpMenuAsCommandBarPopup

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

CallDeleteMenuItem

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

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

IfcbrpMenuIsNothingThen

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

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

ExitSub

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

EndSub

SubDeleteMenuItem()

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

On Error Resume Next

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

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

EndSub