Обучение программированию | Microsoft Access, Excel, Word

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

Тем кто уже знаком с VBA, используйте поиск для нахождения кодов. Наберите, например, DAO, ADO, Recordset и найдете нужную ссылку для решения проблемы с программированием

Microsoft Access. Защита открытия от ключа Shift

03. Shift - это кнопка, удерживая которую вы сможете открыть базу данных без применения макросов, которые запускаются при открытии базы данных. AllowBypassKey - этот ключ сохраняется в свойствах базы. Используя этот метод (3 пример) можно самому сохранить в свойствах файла (не таблицах) некоторые свои параметры.

'==============================================================
'Название
'   Пример 3. Установить защиту
Private Sub butProtOn_Click()
    setProtShift False
    MsgBox "Защита установлена!"  Chr(13)  "Перезапустите базу данных!"
End Sub
'==============================================================
'Название
'   Пример 3. Снять защиту
Private Sub butProtOff_Click()
    setProtShift True
    MsgBox "Защита удалена!"  Chr(13)  "Перезапустите базу данных!"
End Sub
'==============================================================
'Название
'   Пример 3. Основная программа
'   если myFlag = True - защита установлена,
'   если myFlag = False - защита снята
Private Sub setProtShift(myFlag As Boolean)
    dbChangeProperty "StartupForm", DB_TEXT, "Автостарт" 'Первая форма
    dbChangeProperty "StartupShowDBWindow", DB_BOOLEAN, myFlag 'Главное окно Базы данных
    dbChangeProperty "StartupShowStatusBar", DB_BOOLEAN, myFlag 'Нижняя полоска экрана
    dbChangeProperty "AllowBuiltinToolbars", DB_BOOLEAN, myFlag 'Панели инструментов
    dbChangeProperty "AllowFullMenus", DB_BOOLEAN, myFlag 'Меню таблиц, форм и т.п.
    dbChangeProperty "AllowBreakIntoCode", DB_BOOLEAN, myFlag 'Ошибки в модуле
    dbChangeProperty "AllowSpecialKeys", DB_BOOLEAN, myFlag 'Специальные ключи (CTRL+BREAK, ...)
    dbChangeProperty "AllowBypassKey", DB_BOOLEAN, myFlag 'Ключ Shift
End Sub

'==============================================================
'Название
'   Пример 3. Изменить/создать свойство базы данных (см. лекции 2е-2f)
'Параметры:
'   strName - имя свойства (Description, Format ...)
'   varType - тип свойства (dbText, dbLong ...)
'   varValue - значение свойства
'
Function dbChangeProperty(strName As String, varType As Variant, varValue As Variant) As Boolean
Dim prp As Variant, dbs As Database
    
    On Error GoTo 999 'Назначаем переход по ошибке
    dbChangeProperty = False 'Возвращаем результат при ошибке
    
    Set dbs = CurrentDb 'Выбираем базу
    dbs.Properties(strName) = varValue 'Присваиваем значение
    
    dbChangeProperty = True 'Возвращаем результат
    Exit Function 'Выходим из программы
999:
    If Err = 3270 Then  'Свойство не найдено
        Set prp = dbs.CreateProperty(strName, varType, varValue) 'Создаем свойство
        dbs.Properties.Append prp 'Добавляем свойство
        Err.Clear 'Очищаем поток от ошибки
        Resume Next 'Возвращаемся к следующему оператору
    End If
    Err.Clear 'Очищаем от незнакомой ошибки
End Function

Microsoft Access. Рисование объектов в форме.

02. Данный способ позволяет вам нарисовать некоторые объекты в форме, хотя в программе Международный Туризм использовался другой алгоритм для рисования карты. Этот способ может Вам пригодится в некоторых случаях. Рисуются линии, точки, элипсы, многоугольники, т.е. те базовые объекты, которые применяются в api интерфейсе.

' Функция используется для поиска окна
 Private 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

' Функция возвращает контекст устройства для рисования
Private Declare Function apiGetDC Lib "user32" Alias "GetDC" _
    (ByVal hwnd As Long) _
    As Long
 
' Функция освобождает контекст устройства для других приложений
Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" _
    (ByVal hwnd As Long, _
    ByVal hDc As Long) _
    As Long

'==============================================================
' Далеее идут, функции управляющие рисованием

' Функция рисует точку на экране
Private Declare Function apiSetPixel Lib "gdi32" Alias "SetPixel" _
    (ByVal hDc As Long, _
     ByVal x As Long, _
     ByVal Y As Long, _
     ByVal crColor As Long) As Long

' Функция рисует линию из текущей позиции "пера" до точки с координатами
' x,y, но не включая ее саму. Линия рисуется с помощью выбранного "пера". Если
' нет ошибки, то текущее положение пера устанавливается в точку с координатами
' (x,y)
Private Declare Function apiLineTo Lib "gdi32" Alias "LineTo" _
    (ByVal hDc As Long, _
    ByVal x As Integer, _
    ByVal Y As Integer) _
    As Long

' Функция рисует дугу элипса с помощью выбранного "пера".
' Дуга рисуется против часовой стрелки.
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги.
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiArc Lib "gdi32" Alias "Arc" _
    (ByVal hDc As Long, _
    ByVal X1 As Integer, _
    ByVal Y1 As Integer, _
    ByVal X2 As Integer, _
    ByVal Y2 As Integer, _
    ByVal X3 As Integer, _
    ByVal Y3 As Integer, _
    ByVal X4 As Integer, _
    ByVal Y4 As Integer) _
    As Long
' Функция рисует прямоугольник с помощью выбранного "пера".
' (x1,y1) - первый угол
' (x2,y2) - противоположный угол
Private Declare Function apiRectangle Lib "gdi32" Alias "Rectangle" _
    (ByVal hDc As Long, _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long) As Long

' Функция передвигает позицию рисования
' (x,y) - новая точка
' (lpPoint) - предыдущая точка
Private Declare Function apiMoveTo Lib "gdi32" Alias "MoveToEx" _
    (ByVal hDc As Long, _
     ByVal x As Long, _
     ByVal Y As Long, _
     lpPoint As POINTAPI) As Long
' Структура координаты точки
Private Type POINTAPI
    x As Long
    Y As Long
End Type

' Функция рисует элипс с помощью выбранного "пера".
' (x1,y1) - первый угол
' (x2,y2) - противоположный угол
Private Declare Function apiEllipse Lib "gdi32" Alias "Ellipse" _
    (ByVal hDc As Long, _
     ByVal X1 As Long, ByVal Y1 As Long, _
     ByVal X2 As Long, ByVal Y2 As Long) As Long

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

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

' Функция заливает круг с помощью выбранного "пера"
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiChord Lib "gdi32" Alias "Chord" _
    (ByVal hDc As Long, _
     ByVal X1 As Long, ByVal Y1 As Long, _
     ByVal X2 As Long, ByVal Y2 As Long, _
     ByVal X3 As Long, ByVal Y3 As Long, _
     ByVal X4 As Long, ByVal Y4 As Long) As Long

' Функция заливает круг с помощью выбранного "пера"
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiPie Lib "gdi32" Alias "Pie" _
    (ByVal hDc As Long, _
     ByVal X1 As Long, ByVal Y1 As Long, _
     ByVal X2 As Long, ByVal Y2 As Long, _
     ByVal X3 As Long, ByVal Y3 As Long, _
     ByVal X4 As Long, ByVal Y4 As Long) As Long

'==============================================================
'  Назначение
'    Нарисовать объекты
'
Private Sub butExecute_Click()
Dim hwnd As Long, hDc As Long 'Окно и контекст рисования
Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
Dim xy(3) As POINTAPI 'Точки рисования
On Error GoTo 999
 
    'Очистить зону рисования
    Me.Refresh
    DoEvents
    
    'Поиск окна для рисования. Это решение предложено
    'Николаем Малютиным г.Якутск: malnik@mail.ru
    hwnd = FindWindowEx(Me.hwnd, FindWindowEx(Me.hwnd, 0, "OFormSub", ""), "OFormSub", "")
    
    'Выбираем контекст устройства
    hDc = apiGetDC(hwnd)
    
    'Координаты зоны рисования
    X1 = 15
    Y1 = 90
    X2 = 180
    Y2 = 250
    
    'Рисуем объекты
    Select Case Me.Объекты
        Case 1: 'Точка - красная
            Call apiSetPixel(hDc, X2 / 2, Y2 / 2, RGB(255, 0, 0))
        Case 2: 'Линия
            Call apiMoveTo(hDc, X1, Y1, xy(0)) 'Передвигаем указатель
            Call apiLineTo(hDc, X2, Y2) 'Рисуем линию
        Case 3: 'Элипс
            Call apiEllipse(hDc, X1, Y1, X2, Y2 / 2)
        Case 4: 'Прямоугольник - закрашенный
            Call apiRectangle(hDc, X1, Y1, X2, Y2)
        Case 5: 'Дуга
            Call apiArc(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
        Case 6, 7: 'Ломаная, Заливка
            ' Загружаем координаты
            xy(0).x = X1
            xy(0).Y = Y1
            xy(1).x = X1 + 20
            xy(1).Y = Y2
            xy(2).x = X2
            xy(2).Y = Y2 - 20
            If Me.Объекты = 6 Then 'Ломаная
                Call apiPolyline(hDc, xy(0), UBound(xy))
            Else 'Заливка
                Call apiPolygon(hDc, xy(0), UBound(xy))
            End If
        Case 8: 'Заливка круга до хорды
            Call apiChord(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
        Case 9: 'Заливка круга из центра
            Call apiPie(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
    End Select
    
    'Освобождаем контекст устройства
    Call apiReleaseDC(hwnd, hDc)
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

Microsoft Access. Использование StatusBar в Microsoft Access

Данный пример показывает как можно использовать элементStatusBar в Microsoft Access. Не забудьте подключить в новых файлах C:\Windows\System32\mscomctl.ocx

Private WithEvents sl As Slider ' Скользящая шкала
Dim sb As statusBar ' Строка комментариев
Dim pr As ProgressBar ' Шкала загрузки

'
' Настройка процесса в форме
Private Sub Form_Open(Cancel As Integer)
   
   ' Инициализация
   Set sl = Me.mySlider.Object
   sl.Min = 1
   sl.Max = 50
   sl.Value = 25
   
   ' Инициализация указателя загрузки
   Set pr = Me.myProgressBar.Object
   pr.Min = 1
   pr.Max = 10000
   
   ' Инициализация панелей
   Set sb = Me.myStatusBar.Object
   With sb.Panels
      .Clear ' Удаление всех данных
      .Add 1, "k1", "Загрузка"
      .Add 2, "k2", " "
      .Item(1).MinWidth = 850 ' Ширина панели
   End With
End Sub

'   Запуск процесса
Private Sub butProgress_Click()
Dim i As Long
    Me.Tag = "Start"
    For i = 1 To 10000
        ' Меняем сообщение с определенным шагом
        If (i / sl.Value) = (i \ sl.Value) Then
            pr.Value = i
            sb.Panels(2).Text = "Всего: "  i
            DoEvents ' Надо только для события sl_Change
        End If
        If Me.Tag = "Stop" Then Exit For
    Next i
    pr.Value = 1
    sb.Panels(2).Text = ""
End Sub

'   Определение события Slider
Private Sub sl_Change()
    Me.Tag = "Stop" ' Определяем флаг для выхода из процесса
End Sub

'   Освобождение ресурсов
Private Sub Form_Close()
    Set pr = Nothing
    Set sb = Nothing
End Sub

Microsoft Access. Создание TreeView в Microsoft Access

Данный пример показывает как можно использовать элемент TreeView в Microsoft Access. Не забудьте подключить в новых файлах C:\Windows\System32\mscomctl.ocx

Public WithEvents myTV As MicrosoftTree

'  Управление Microsoft TreeView c демонстрацией событий
Private Sub butCreate_Click()
    If myTV Is Nothing Then
        ' Создание объекта
        Set myTV = New MicrosoftTree
        Set myTV.Tree = Me.myTree.Object
        ' Загружаем узлы дерева
        myTV.Load "SELECT * FROM [TableTreeView] Order By [Index]"
    End If
End Sub

'   Добавим событие-сообщение для нового класса
Public Sub myTV_Progress(myMsg As String)
    If Me.butEvents Then
        Me.myEvents = myMsg  vbNewLine  Me.myEvents
        DoEvents
    End If
End Sub
Private Sub myTree_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Long, ByVal y As Long)
   myTV_Progress "MouseDown"
   myTV.MouseDown Button, Shift, x, y
End Sub
Private Sub butEvents_AfterUpdate()
    Me.myEvents = ""
End Sub

'   Освобождение ресурса
Private Sub Form_Close()
    Set myTV = Nothing
End Sub

' ------------ Класс -----------
'==============================================================
'  Переменные и события

' Объявляем класс Tree
Public WithEvents Tree As TreeView

' Объявляем событие для сообщений
Public Event progress(strMsg As String)

' Переменные для перемещения
Private Type DropDrag
    idxStart As Long ' Начальный узел перемещения
    idxEnd As Long   ' Конечный узел перемещения
End Type

Private drag As DropDrag ' Переменная перемещения

'==============================================================
'  События при создании/уничтожении класса
Private Sub Class_Initialize()
   ' Инициализация
   'funPrintEvent "Class_Initialize"
End Sub
Private Sub Class_Terminate()
   ' Сохраняем данные
   'funPrintEvent "Class_Terminate"
End Sub

'==============================================================
'  События до/после редактирования метки узла
Private Sub Tree_BeforeLabelEdit(Cancel As Integer)
   funPrintEvent "BeforeLabelEdit"
End Sub
Private Sub Tree_AfterLabelEdit(Cancel As Integer, NewString As String)
   funPrintEvent "AfterLabelEdit: "  NewString
   Me.Tree.SelectedItem.ForeColor = 255
End Sub

'==============================================================
'  События при работе с узлами дерева
Private Sub Tree_NodeClick(ByVal node As node)
   funPrintEvent "NodeClick: "  node.Text
End Sub
Private Sub Tree_NodeCheck(ByVal node As node)
   funPrintEvent "NodeCheck: "  node.Text
End Sub
Private Sub Tree_Expand(ByVal node As node)
   funPrintEvent "Expand: "  node.Text
End Sub
Private Sub Tree_Collapse(ByVal node As node)
   funPrintEvent "Collapse: "  node.Text
End Sub

'==============================================================
'  События при управлении левой кнопкой мыши
Private Sub Tree_Click()
    funPrintEvent "Click"
End Sub
Private Sub Tree_DblClick()
    funPrintEvent "DblClick"
End Sub

'==============================================================
'  События клавиатуры
Private Sub Tree_KeyUp(KeyCode As Integer, ByVal Shift As Integer)
    funPrintEvent "KeyUp (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub
Private Sub Tree_KeyDown(KeyCode As Integer, ByVal Shift As Integer)
   funPrintEvent "KeyDown (KeyCode: "  KeyCode  ", Shift = "  Shift  ")"
End Sub
Private Sub Tree_KeyPress(KeyAscii As Integer)
   funPrintEvent "KeyPress: "  KeyAscii
End Sub

'==============================================================
' События для перемещения типа DragDrop. Возможны только при
' настройках TreeView. Например,
'        .OLEDragMode = ccOLEDragAutomatic
'        .OLEDropMode = ccOLEDropManual

' Событие. Начало перемещения.
Private Sub Tree_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
    ' AllowedEffects = ccOLEDropEffectCopy ' Доступные режимы
    funPrintEvent "OLEStartDrag"
    Set Me.Tree.DropHighlight = Nothing ' Освобождение ресурса
    drag.idxEnd = -1 ' Освобождение позиции
End Sub

' Событие. Изменение координат мыши x и y.
' Для определения текущего узла используем: DropHighlight, HitTest(X, y)
Private Sub Tree_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
    funPrintEvent "OLEDragOver: x="  x  ", y="  y
    With Me.Tree
        Set .DropHighlight = .HitTest(x, y)
    End With
End Sub
' Событие - Срабатывает после OLEDragOver
Private Sub Tree_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
    funPrintEvent "OLEGiveFeedback: Effect="  Effect  ", defaultCursors="  DefaultCursors
End Sub
' Событие. Последние событие до завершения перемещения.
Private Sub Tree_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
   With Me.Tree
        Set .DropHighlight = .HitTest(x, y) ' Узел завершения
        funPrintEvent "OLEDragDrop: "  Nz(.HitTest(x, y))
        If Not .DropHighlight Is Nothing Then
             drag.idxEnd = .HitTest(x, y).Index
        End If
   End With
End Sub

' Событие. Завершение перемещения
' Для определения действий с узлами использем DropHighlight и SelectedItem
Private Sub Tree_OLECompleteDrag(Effect As Long)
Dim strKey As String
    'Me.Tree.MousePointer = ccArrow
    With Me.Tree
        Set .DropHighlight = Nothing ' Освобождаем объект
        If (drag.idxStart = -1) Or _
           (drag.idxEnd = -1) Or _
           (drag.idxStart = drag.idxEnd) Then
             funPrintEvent "OLECompleteDrag: None"
        Else
             funPrintEvent "OLECompleteDrag: "  .Nodes(drag.idxStart).Text  " - "  .Nodes(drag.idxEnd).Text
             ' Функция обработки операции DragDrop
             strKey = "la_"  Time
             ' Добавляем узел красного цвета
             Set .SelectedItem = .Nodes.Add(.Nodes(drag.idxEnd).Key, tvwChild, strKey, "Новый узел")
             .SelectedItem.ForeColor = 255
        End If
    End With
End Sub

' Событие. Установка данных
Private Sub Tree_OLESetData(Data As DataObject, DataFormat As Integer)
    funPrintEvent "OLESetData"
End Sub

' Событие. Обработка нажатия клавиши
Public Sub MouseDown(Button As Integer, Shift As Integer, x As Long, y As Long)
    With Me.Tree
        If .HitTest(x, y) Is Nothing Then
            drag.idxStart = -1
        Else
            Set .SelectedItem = .HitTest(x, y)
            drag.idxStart = .SelectedItem.Index
        End If
    End With
    If Button = acLeftButton Then
        drag.idxEnd = -1 ' Индекс последнего элемента не известен
    End If
End Sub

'==============================================================
'   Собственные свойства класса

Public Function Load(strSQL As String) As Boolean
Dim myУзел As String, myКлюч As String, idx As Long
Dim rst As ADODB.Recordset
    On Error GoTo 999
    
    ' Загрузка дерева
    Set rst = New ADODB.Recordset
    rst.Open strSQL, Application.CurrentProject.Connection
    Me.Tree.Nodes.Clear
    Do Until rst.EOF
        ' Создание узла и его ключей
        myУзел = "la_"  rst!Relative
        myКлюч = "la_"  rst!Key
        If Not IsNull(rst!Relative) Then
             idx = Me.Tree.Nodes.Add(myУзел, tvwChild, myКлюч).Index
        Else
             idx = Me.Tree.Nodes.Add(, , myКлюч).Index
        End If
        ' Изменение нового узла
        With Me.Tree.Nodes(idx)
            .Text = Nz(rst!Text)
            .Selected = True
        End With
        rst.MoveNext
    Loop
    
    ' Настраиваем класс
    With Me.Tree
        ' Разрешаем операцию DragDrop
        .OLEDragMode = ccOLEDragAutomatic
        .OLEDropMode = ccOLEDropManual
        
        ' Настраиваем дерево
        .Style = tvwTreelinesPlusMinusText ' Общий вид дерева
        .LineStyle = tvwRootLines ' Использование корневого узла
        .Indentation = 300 ' Длина штриха узла
        .Checkboxes = True ' Показываем флажки
    End With
    
    Load = True
    
998:
    rst.Close
    Set rst = Nothing
    Err.Clear
    Exit Function
999:
    Load = False
    MsgBox Err.Description
    On Error Resume Next
    Resume 998
End Function

'==============================================================
'   Функция сообщающая о получении событий
Private Function funPrintEvent(myMsg As String)
    RaiseEvent progress(myMsg) ' Генерируем событие для узла
End Function

Microsoft Access. Отправить письмо из Outlook

01. Этот пример (1) позволяет вам отправить электронное сообщение из Access через Outlook. Для работы программы в новых файлах создайте ссылку на Outlook в VBA: C:\Program Files\Microsoft Office\OFFICE11\MSOUTL.OLB

'==============================================================
'  Назначение
'    "Послать почту из базы данных"
Private Sub butExecute_Click()
Dim app As Outlook.Application  'Приложение программы
Dim dbs As Database 'База данных
Dim rst As Recordset 'Источник email
Dim i As Integer 'Счетчик
Dim itm As MailItem 'Почтовое сообщение
Dim myFile As String 'Присоединяемый файл

    On Error GoTo 999
    Set dbs = CurrentDb 'Выбор базы данных
    Me.Refresh 'Сохраняем данные
    myFile = Application.CurrentProject.Path  "\"  Me.Attachment
    myFile = Dir(myFile)
    'Открываем таблицу c почтовыми адресами
    Set rst = dbs.OpenRecordset("SELECT * FROM [Пример 01email] WHERE ([Вкл]=True);")
    If rst.RecordCount  0 Then 'Проверяем записи
        rst.MoveLast 'Заполняем запрос
        rst.MoveFirst 'Первая запись
        Set app = New Outlook.Application 'Новое сообщение
        Dim myNamespace, myfolder As MAPIFolder, mynewfolder
        Set myNamespace = app.GetNamespace("MAPI")
        Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
        'Set myfolder = _
        '    app.ActiveExplorer.CurrentFolder.Folders
        Set mynewfolder = myfolder.Folders.Add("My Contacts")
        
        Set itm = app.CreateItem(olMailItem) 'Добавляем письмо
        itm.Subject = Me.Subject  'Тема письма
        itm.Body = Me.Body 'Текст письма
        If myFile  "" Then itm.Attachments.Add myFile 'Прикрепляем файл
        For i = 0 To rst.RecordCount - 1 'Просматриваем адреса
            If rst!Вкл = True Then _
                itm.Recipients.Add rst!Email 'Добавляем новый адрес
            rst.MoveNext 'Следующий адрес
        Next
        itm.Send 'Отсылаем письмо
        app.Quit 'Закрываем Outlook
        MsgBox "Письмо успешно отправлено!", vbExclamation, "Почта"
    End If
    rst.Close 'Закрываем запрос
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub

Microsoft Access. Создание элемента ListView

Данный пример показывает как можно использовать элемент List View в Microsoft Access. Не забудьте подключить в новых файлах C:\Windows\System32\mscomctl.ocx

Public myNewList As MicrosoftList

'  Управление Microsoft ListView c демонстрацией событий
'
Private Sub Form_Load()
    If myNewList Is Nothing Then
        ' СоздУслуги, упаковка,транспорт, наценкаание объекта
        Set myNewList = New MicrosoftList
        Set myNewList.Tree = Me.myList.Object
        ' Загружаем узлы дерева из запроса
        myNewList.Load "sqlListView"
    End If
End Sub


'  ----------- Объявляем класс List из Mscomctl.ocx --------
Public WithEvents Tree As MSComctlLib.ListView

' Объявляем событие для сообщений
'==============================================================
'  События при создании/уничтожении класса
Private Sub Class_Initialize()
   ' Инициализация
End Sub
Private Sub Class_Terminate()
   ' Сохраняем данные
End Sub

'==============================================================
'  События при нажатии рисунка
Private Sub Tree_ItemClick(ByVal Item As ListItem)
    'MsgBox Item.Text
End Sub
Private Sub Tree_DblClick()
    MsgBox Me.Tree.SelectedItem.Text, vbInformation, "Двойное нажатие"
End Sub

'==============================================================
'   Другие свойства класса

Public Function Load(strSQL As String) As Boolean
Dim myKey As String, idx As Long
Dim rst As ADODB.Recordset
    On Error GoTo 999
    
    ' Загрузка дерева
    Set rst = New ADODB.Recordset
    rst.Open strSQL, Application.CurrentProject.Connection
    Me.Tree.ListItems.Clear
    idx = 1
    Do Until rst.EOF
        ' Создание узла и его ключей
        myKey = "la_"  rst!Тип
        Me.Tree.ListItems.Add idx, myKey, Nz(rst!Наименование), CStr(rst!Icon), CStr(rst!Icon)
        rst.MoveNext
        idx = idx + 1
    Loop
    Load = True
    
998:
    rst.Close
    Set rst = Nothing
    Err.Clear
    Exit Function
999:
    Load = False
    MsgBox Err.Description
    On Error Resume Next
    Resume 998
End Function

Microsoft Access. Печать отчета через DoCmd.RunCommand

12. Используя этот пример, Вы сможете печатать отчет через DoCmd.RunCommand acCmdPrint

'12. Печать на нескольких принтерах
Private Sub Example12_Click()
    On Error GoTo 999 'Выход по ошибке
    While (1) 'Назначаем бесконечный цикл
        DoCmd.SelectObject acReport, "Пример 12", True 'Выбираем отчет в БД
        DoCmd.RunCommand acCmdPrint 'Вызываем печать
    Wend
999:
    Err.Clear 'Очищаем ошибку при отмене печати
    DoCmd.SelectObject acForm, Me.Name  'Выбираем форму
End Sub

Microsoft Access. Работа с датами DateSerial

Некотые данные вы можете получить из таблиц, используя функции времени. DateSerial - это такая фукнция

-- Использование функции Format
SELECT Продукт, Цена, Format(Now(),'YYYY-MM-DD') as ДатаЗаказа FROM Продукты

-- Выборка между 2 датами, американский стандарт
SELECT Дата FROM Данные WHERE ([Дата] 
BETWEEN DateSerial(Year(Date()),Month(Date())-2,1) And #2/20/2005#);

Microsoft Access. Использование QueryDef

Очень частов базах данных используются запросы с параметрами. В этом примере дано 2 варианта их применения.

dim q as dao.querydef
dim txt as stringtxt="select ... where val='"  Me.Val  "'"
set q=currentdb.querydefs("MyQ")
q.sql=txt
set q=nothing
docmd.Openquery "MyQ"

/*
'Dim dbs As DAO.Database
'Dim qdf As DAO.QueryDef
'
'Set dbs = CurrentDb
'Set qdf = dbs.QueryDefs("МойЗапросСПараметром")
'qdf.Parameters("ПараметрВЗапросе") = 1
*/

Microsoft Access. Скрыть объекты базы от просмотра

08. Пример 8 показывает защиту базы данных путем скрытия ее объектов: таблиц, запросов, полей

Private Sub butExecute_Click()
Dim dbs As DAO.Database, tdf As DAO.TableDef, fld As DAO.Field, prpLoop As DAO.Property
    ' Отображаем/гасим невидимые объекты базы данных
    Application.SetOption "Show Hidden Objects", CBool(Not Me.flagViewObject)
    
    ' DAO - метод
    Set dbs = CurrentDb
    Me.progress = ""
    For Each tdf In dbs.TableDefs
        If ((tdf.Attributes And dbSystemObject) = 0) Then
            ' Отображаем/гасим таблицы пользователя
            Me.progress = Me.progress  tdf.Name  ", Visible="  (Not CBool(Me.flagViewTable))  vbNewLine
            Application.SetHiddenAttribute acTable, tdf.Name, Me.flagViewTable
            ' Отображаем/гасим поля пользователя
            For Each fld In tdf.Fields
                fld.Properties("ColumnHidden") = CBool(Me.flagViewField)
            Next fld
        End If
    Next tdf
    
End Sub