Программирование на Visual Basic | Архив файлов mdb (accdb)

В этом разделе сайта находятся примеры из сборника программ "Архив файлов на Microsoft Access". В нем рассказывается о программировании форм, отчетов, таблиц и других объектов. Используйте этот архив для изучения работы с приложением Microsoft Office Access и программированием на Visual Basic for Application. Файлы исходников можно получить по этой ссылке: Купить и скачать

Microsoft Access. Управление редактором RTF из Access

Данный пример показывает как можно редактировать тексты rtf в Microsoft Access (..\05 Конверторы\la_convert.accdb).

'сохранение текущей записи в файле в формате RTF
Private Sub cmdSave_Click()
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftemp"  Me.ID  ".rtf"
End Sub

'сохранение всех записей в файле в формате RTF
Private Sub cmdSaveAll_Click()
Dim i As Long, p As Long
Dim strtemp As String, strrtf As String
    'разделитель записей (по желанию)
    Const spl = "\rtf1\ansi\ansicpg1251\deff0\deflang1049{\fonttbl{\f0\fnil\fcharset0 Tahoma;}}"  _
    "\viewkind4\uc1\pard\f0\fs24 ************************************"  _
    "\par"
    
    'сведем все записи воедино
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo False
    For i = 1 To DCount("[ID]", "T1")
         strtemp = Me.RichTextBox1.TextRTF
         'для "нормального" склеивания фрагментов текста надо удалить лишние "}" "{"
         p = InStrRev(strtemp, "}")
         strtemp = Left(strtemp, p - 1)
         p = InStr(strtemp, "{")
         strtemp = Right(strtemp, Len(strtemp) - p)
         strrtf = strrtf  strtemp  spl
         DoCmd.GoToRecord , , acNext
    Next i
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo True
    
    'восстановим начальные и конечные "{"
    strrtf = "{"  strrtf  "}"
    
    'чтобы полученный не влиял на данные, отключим RichTextBox от данных
    strtemp = Me.RichTextBox1.ControlSource
    Me.RichTextBox1.ControlSource = ""
    Me.RichTextBox1.TextRTF = strrtf
    
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftempall.rtf"
    
    'восстановим нормальную работу
    Me.RichTextBox1.ControlSource = strtemp
End Sub

'управление насыщенностью
Private Sub ctlBold_AfterUpdate()
    Select Case Me.ctlBold.Value
    Case -1
    Me.RichTextBox1.SelBold = True
    Case 0
    Me.RichTextBox1.SelBold = False
    End Select
    Me.RichTextBox1.SetFocus
End Sub

Microsoft Access. Примеры построения графиков в формах

03. Первая часть - при загрузке формы скрывается ее заголовок. Средствами Access можно убрать строку меню и границу, но тогда форма не имеет четко выраженной границы. Вторая часть - рисование полилиний разного цвета. При построении графиков для наглядности удобно представлять данные разными цветами в зависимости от уровня стандартные средства этого почему-то не поддерживают. Третья часть - пример использования регионов (..\02 Графика\la_graphics.accdb).

'константы для функции пересчета твипов
'значения 88 и 90 могут отличаться!
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

'константы для функции скрытия заголовка
Public Const STYLE = (-16)
Public Const CAPTION = HC00000
Public Const BORDER = H800000
Public Const NOMOVE = H2
Public Const NOSIZE = H1
Public Const NOZODER = H4
Public Const ShowWindow = H40
Public Const NOACTIVE = H10
Public Const FRAMECHANGED = H20

'вычисление коэффициента пересчета Twip в Pixel
Public Function TwipToPixel(i As Long) As Long
    Dim hDc As Long
    'получение идентификатора контеста устройства
    hDc = GetDC(0)
    Select Case i
    Case 1
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSX)
    Case 2
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSY)
    End Select
    'освобождение идентификатора
    ReleaseDC 0, hDc

End Function
'--
'GetDC возвращает контекст устройства (DC) окна
Public Declare Function GetDC Lib "user32" (ByVal hw As Long) As Long
'ReleaseDC освобождает ресурсы,которые были заняты
'при использовании GetDC для получения контекста устройства
Public Declare Function ReleaseDC Lib "user32" (ByVal hw As Long, ByVal hDc As Long) As Long

'получение характеристик дисплея
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, _
   ByVal iCapability As Long) As Long

'функция позволяет получить используемый стиль окна
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long

'функция позволяет установить новый стиль окна
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
'функция отображает окно в указанном месте
Public Declare Function SetWindowPos Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal _
wFlags As Long) As Long

' Функция используется для поиска окна
 Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hWndParent As Long, _
   ByVal hWndChildAfter As Long, _
   ByVal lpClassname As String, _
   ByVal lpWindowName As String) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polygon Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, ByVal nCount As Long) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polyline Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, _
     ByVal nCount As Long) As Long



' Структура координаты точки
Public Type POINTAPI
    x As Long
    Y As Long
End Type


'функция выбирает устройство для рисования
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hDc _
As Long, ByVal hObject As Long) As Long

'функция удаляет созданный объект для освобождения ресурсов
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject _
As Long) As Long

'функция создает новое "перо"
Public Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle _
As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

'функция создает новую "кисть"
Public Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal _
crColor As Long) As Long

'функция создает прямоугольный регион
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'функция создает комбинацию из двух регионов
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long

'функция отображает регион на окно
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'функция позволяет получить размеры и положение окна
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As _
Long, lpRect As Rect) As Long

'структура для данных, получаемых GetWindowRect
 Public Type Rect
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

'функция управляет "показом" окна
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As _
Long, ByVal nCmdShow As Long) As Long
'--



Public Function Скрыть_Заголовок(frm As Form, IndexX As Long, IndexY As Long)
    Dim OldStyle As Long, NewStyle As Long
    Dim x As Long, Y As Long
    
    'получение текушего стиля окна
    OldStyle = GetWindowLong(frm.hwnd, STYLE)
    
    'определение и установка нового стиля окна
    NewStyle = (OldStyle And Not CAPTION) Or BORDER
    SetWindowLong frm.hwnd, STYLE%, NewStyle
    
    'настройка размеров окна
    x = frm.Width \ IndexX
    Y = frm.Section(acDetail).Height \ IndexY
    
    'отображение окна с новыми свойствами
    SetWindowPos frm.hwnd, 0, 0, 0, x, Y, NOMOVE Or NOZODER Or FRAMECHANGED

End Function

Microsoft Access. Развернуть таблицу на все окно

09. По умолчанию таблицы открываются в небольшом окне, для того чтобы их открыть на все окно используйте этот пример.

Private Sub butExecute_Click()
    On Error GoTo 999
    funOffBars 'Гасим все панели
    DoCmd.ShowToolbar "Menu Bar", acToolbarYes 'Строка меню
    DoCmd.ShowToolbar "Table Datasheet", acToolbarYes 'Меню таблиц
    DoCmd.OpenTable "Пример 01", acViewNormal 'Открываем таблицу
    DoCmd.Maximize 'Масштабирование
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Масштабирование"
    Err.Clear
End Sub

Microsoft Access. Проверка орфографии в Access, используя Microsoft Word

06. Данный пример показывает как можно проверять текстовые документы в Access, используя Word. Дается 2 варианта - быстрый и медленный с вызовом диалога коррекции текста.

'  Проверка текста с диалогом
Private Sub butExecute_Click()
Dim app As Word.Application  'Приложение программы
'Dim obj As Object  'Приложение программы, 2 вариант

    On Error GoTo 999

    ' Нужна проверка на ввод текст
    If Nz(Me.Text, "") = "" Then
        MsgBox "Введите текст!"
        Exit Sub
    End If
    
    ' Сообщение о начале проверки
    Me.Result = "Думаю ... Для замены фраз откройте Word"
    DoEvents

    Set app = New Word.Application
'   Set app = CreateObject("Word.Application") ' 2 вариант
   
    With app
        ' Отображаем Word
        .Visible = True
        
        ' Добавляем документ для проверки
        .Documents.Add
    
        ' Печатаем проверяемый текст
        .Selection.TypeText Me.Text
        
        ' Настраиваем опции проверки
        .Options.CheckGrammarWithSpelling = False
        .Options.IgnoreUppercase = False
    
        ' Выполняем проверку
        .ActiveDocument.CheckSpelling
    
        ' Выбираем новый для проверки текст
        .Selection.WholeStory
    
        ' Копируем текст в буфер
        .Selection.Copy
    
        ' Возвращаем результат после проверки
        Me.Result = .Selection.Text
        
        ' Возвращаем текст из буфера
        ' Me.Result = Clipboard.GetText
    
        ' Закрываем Word
        .ActiveDocument.Close (0)
        .Quit
    End With
    
    ' Закрываем приложение
    Set app = Nothing
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

' Быстрая проверка на наличие ошибок
Private Sub butExecute2_Click()
Dim app As Word.Application
'Dim obj As Object  'Приложение программы, 2 вариант

    On Error GoTo 999
    
    ' Нужна проверка на ввод текст
    If Nz(Me.Text, "") = "" Then
        MsgBox "Введите текст!"
        Exit Sub
    End If
    
    ' Сообщение о начале проверки
    Me.Result = "Думаю ..."
    DoEvents
    
'   Set app = CreateObject("Word.Application") ' 2 вариант
   Set app = New Word.Application
   
   ' Быстрая проверка
    If app.CheckSpelling(Me.Text) Then
        Me.Result = "Проверка текста прошла успешно!"
    Else
        Me.Result = "В тексте есть ошибки"
    End If
    
    ' Освобождаем память
    app.Quit
    Set app = Nothing
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

Microsoft Access. Поиск по нескольким полям

Есть таблица, в ней нужно провести поиск по нескольким полям. При этом одно поле зависит от другого. Как это сделать указано в это примере (..\15 Формы\la_from.accdb\02. Поиск по нескольким полям).

'==============================================================
' Поиск по дате
Private Sub Дата_AfterUpdate()
Dim rst As Recordset, frm As Form
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    rst.FindFirst "([Дата]=#"  Format(Me.Дата, "mm\/dd\/yyyy")  "#)"
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
        Me.Книга = rst!Книга
    Else
        MsgBox "Нет данных!"
    End If
    
    Exit Sub
999:
    MsgBox Err.Description  vbNewLine  "Введите правильно данные?"
End Sub

'==============================================================
' Начать поиск после обновления
Private Sub Книга_AfterUpdate()
    recordFind
End Sub

'==============================================================
' Поиск по дате и книге
Private Sub recordFind()
Dim rst As Recordset, frm As Form, s As String
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    s = "([Дата]=#"  Format(Me.Дата, "mm\/dd\/yyyy")  _
                  "#) and (Книга='"  Me.Книга  "')"
    rst.FindFirst s
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
    Else
        MsgBox "Нет данных!"
    End If
    
    Exit Sub
999:
    MsgBox "Введите правильно данные?"
End Sub

'==============================================================
' Поиск по шаблону
Private Sub Шаблон_AfterUpdate()
Dim rst As Recordset, frm As Form, s As String
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    rst.FindFirst "([Книга] Like '"  Me.Шаблон  "')=True"
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
    Else
        MsgBox "Нет данных!"
    End If
    Exit Sub
999:
    MsgBox "Введите правильно данные?"
End Sub

'==============================================================
' Запрос по книге
Private Sub Книга_Enter()
    Me.Книга.RowSource = "SELECT Книга FROM [1-Мои книги] WHERE (((Дата)=[Forms]![Example 01]![Дата]));"
    'Me.Книга.Requery  'Изменить запрос
End Sub

Microsoft Access. Автовычисление полей в форме

15. Некоторые виды интерфейса требуют, чтобы в полях показывался результат выполнения нескольких полей. Например, итоговая сумма по заказу. Это делается следующим способом.

Private Sub Form_Open(Cancel As Integer)
    Me.Итого.ControlSource = "=[Сумма]*[Наценка]"
End Sub

Microsoft Access. Свойства папки и ее объектов

Этот пример покажет Вам как правильно определить различные свойства папок в Windows. Вы также сможете прочитать свойства томов, системных папок и т.п.

' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butProperties_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder)
    Me.progress = _
        "Name: "  f1.Name  vbCrLf  _
        "Path: "  f1.Path  vbCrLf  _
        "Attributes: "  f1.Attributes  vbCrLf  _
        "DateCreated: "  f1.DateCreated  vbCrLf  _
        "LastAccessed: "  f1.DateLastAccessed  vbCrLf  _
        "LastModified: "  f1.DateLastModified  vbCrLf  _
        "IsRootFolder: "  f1.IsRootFolder  vbCrLf  _
        "ShortName: "  f1.ShortName  vbCrLf  _
        "ShortPath: "  f1.ShortPath  vbCrLf  _
        "Size: "  f1.Size  vbCrLf  _
        "Type: "  f1.Type  vbCrLf  _
        "fs.FolderExists('c:\')="  fs.FolderExists("c:\")  vbCrLf  _
        ""
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получение имени специальной папки
'   fs.GetSpecialFolder(0) - 'c:\windows'
'   fs.GetSpecialFolder(1) - 'c:\windows\system'
'   fs.GetSpecialFolder(2) - 'c:\windows\temp
' Получение других имен
'   fs.GetFolder(".") - текущая папка
'   fs.GetFolder("..") - корневая папка
' Проверки для c:
'   fs.FolderExists("c:\") = True - есть на диске
'   fs.GetFolder("c:\").IsRootFolder = True - корневая папка
'
Private Sub butViewSpecFolder_Click()
On Error GoTo 999
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Me.progress = _
        "Папка Windows: "  fs.GetSpecialFolder(0)  vbCrLf  _
        "Папка System: "  fs.GetSpecialFolder(1)  vbCrLf  _
        "Папка Temp: "  fs.GetSpecialFolder(2)  vbCrLf  _
        "Текущая папка: "  fs.GetFolder(Me.myFolder  "\.")  vbCrLf  _
        "Родительская папка: "  fs.GetFolder(Me.myFolder  "\..")  vbCrLf  _
        ""
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получить список файлов
'   fs.GetFolder(".").Files
'
Private Sub butViewFiles_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).Files
    Me.progress = "Count="  fc.Count  vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress  f1.Name  vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Получить список подчиненных папок
'   fs.GetFolder(".").SubFolders
'
Private Sub butViewSubFolders_Click()
On Error GoTo 999
    Dim fs, fc, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fc = fs.GetFolder(Me.myFolder).SubFolders
    Me.progress = "Count="  fc.Count  vbCrLf
    For Each f1 In fc
        Me.progress = Me.progress  f1.Name  vbCrLf
    Next

    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

' Прочитать все свойства папки
'   f1.DateCreate - дата создания папки
'
Private Sub butDrive_Click()
On Error GoTo 999
    Dim fs, f1
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.GetFolder(Me.myFolder).drive
    Me.progress = _
        "DriveLetter: "  f1.DriveLetter  vbCrLf  _
        "AvailableSpace: "  f1.AvailableSpace  vbCrLf  _
        "DriveType: "  f1.DriveType  vbCrLf  _
        "FileSystem: "  f1.FileSystem  vbCrLf  _
        "FreeSpace: "  f1.FreeSpace  vbCrLf  _
        "IsReady: "  f1.IsReady  vbCrLf  _
        "Path: "  f1.Path  vbCrLf  _
        "SerialNumber: "  f1.SerialNumber  vbCrLf  _
        "ShareName: "  f1.ShareName  vbCrLf  _
        "TotalSize: "  f1.TotalSize  vbCrLf  _
        "VolumeName: "  f1.VolumeName
    Exit Sub 'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub

'==============================================================
Private Sub Form_Open(Cancel As Integer)
    ' Устанавливаем каталог
    ChDir Application.CurrentProject.Path
    ' Определение имени новой папки
    Me.myFolder = Application.CurrentProject.Path
End Sub

Microsoft Access. Загрузка файлов bmp из каталога

01. Данный пример показывает вам, как можно загрузить все рисунки из каталога в базу данных. Обратите внимание на Dir("\*.bmp", vbNormal) - таким простейшим и древним способом можно получить все файлы из каталога. Рекомендации для хранения рисунков. Лучше использовать отдельные файлы, хотя в некоторых случаях это может пригодится.

'    Загрузить рисунки из файла в таблицу
'    (Для работы программы в папке должны быть файлы *.bmp)
'
Private Sub butExecute_Click()
Dim myBmp As String, myDir As String
On Error GoTo 999
    ' Папка для поиска
    myDir = Application.CurrentProject.Path
    ' Находим файл с расширением bmp
    myBmp = Dir(myDir  "\*.bmp", vbNormal)
    Do While Len(myBmp)  0 'Проверяем файл
        Me.Файл = myBmp  'Файл bmp
        Me.Папка = myDir 'Каталог
        Me.Рисунок.OLETypeAllowed = acOLEEmbedded 'Назначаем режим вставки
        Me.Рисунок.SourceDoc = Me.Папка  "\"  Me.Файл 'Путь файла
        Me.Рисунок.Action = acOLECreateEmbed 'Вставляем объект в таблицу
        'Переход к новой записи
        myBmp = Dir  'Новый файл bmp
        DoCmd.RunCommand acCmdRecordsGoToNew ' Переходим на новую запись
    Loop
    DoCmd.RunCommand acCmdRecordsGoToFirst 'Начало записей
    MsgBox "Рисунки загружены!", vbExclamation, "Графика"
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

Microsoft Access. Правая кнопка на формах меню

При разработке интерфейса Вам может потребоваться использовать правую кнопку мыши для вызова контекстного меню. Как это сделать программным способом смотрите в этом разделе.

Dim WithEvents myCombo As CommandBarComboBox ' Обработка событий

Const strMenu As String = "Правая кнопка"

Private Sub Form_Open(Cancel As Integer)
    ' Определяем название
    On Error Resume Next
    CommandBars.Item(strMenu).Delete
    Err.Clear
    
    ' Создаем панель меню
    On Error GoTo 999
    Dim myBar As CommandBar
    Set myBar = CommandBars.Add(strMenu, msoBarPopup, , False)
    
    ' Добавляем 1 кнопку
    Dim But As CommandBarButton
    Set But = myBar.Controls.Add(msoControlButton)
    With But
        .Style = msoButtonCaption ' Выбираем стандартный тип
        .FaceId = 1 ' Устанавливаем код кнопки
        .Caption = "Кнопка 1" ' Называем кнопку
        .OnAction = "=msgBox('Привет!')" ' Определяем программу
    End With
    
    ' Создаем список в меню
    Set myCombo = myBar.Controls.Add(msoControlDropdown, , 1)
    With myCombo
        .BeginGroup = True
        .Caption = "Cписок: "
        .Style = msoComboLabel
        .AddItem "Строка 1"
        .AddItem "Строка 2"
        .ListIndex = 2 ' Устанавливаем 2 вариант
        .DropDownWidth = -1 ' Выбираем ширину по самому длинному
    End With
    
    ' Добавляем кнопки меню из других панелей
    ' (для нахождения кодов смотрите пример 05)
    '
    With CommandBars("Menu Bar")
        .FindControl(, 523, , , True).Copy myBar ' Схема данных
        .FindControl(, 210, , , True).Copy myBar ' Сортировка по возрастанию
        .FindControl(, 211, , , True).Copy myBar ' Сортировка по убыванию
        .FindControl(, 19, , , True).Copy myBar ' Копировать в буфер
    End With
   
    ' Просмотр данных из текущей позиции
    ' myBar.ShowPopup
    Exit Sub
999:
    MsgBox Err.Description
End Sub

'==============================================================
'  Отключение
Private Sub butOld_Enter()
    Me.ShortcutMenuBar = ""
End Sub

'==============================================================
'  Включение меню
Private Sub butNew_Enter()
    Me.ShortcutMenuBar = strMenu
End Sub

'==============================================================
'  Включение меню
Private Sub myCombo_Change(ByVal ctrl As CommandBarComboBox)
    MsgBox "Текст: "  ctrl.Text
End Sub