Программирование на Visual Basic

03. В ADO и DAO ошибки обрабатываются по разному, используйте этот пример для анализа действий вашей программы при аварийных выходах.

Option Compare Database
Option Explicit
'***************************************************************
' 03. Обработка ошибок разными методами
'***************************************************************

'==============================================================
' ADO. Обработка ошибок
Private Sub butADO_Click()
Dim cnn As New ADODB.Connection
Dim oneErr As ADODB.Error, s As String
    On Error Resume Next
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=?"
    ' Информация о всех ошибках
    s = "Список ошибок;------ ADO -------;"
    For Each oneErr In cnn.Errors
        s = s  "Описание;"  oneErr.Description  ";"
        s = s  "Номер;"  oneErr.Number  ";"
        s = s  "Имя приложения;"  oneErr.Source  ";"
        s = s  "SQLState;"  oneErr.SQLState  ";"
        s = s  "NativeError;"  oneErr.NativeError  ";"
        s = s  "Код справки;"  oneErr.HelpContext  ";"
        s = s  "Файл справки;"  oneErr.HelpFile  ";"
    Next
    ' Полная информация о последней ошибке
    s = s  "Последняя ошибка;------ ADO -------;"
    Me.listErrors.RowSource = s  funLastError 'Отображаем ошибку
    Resume Next
End Sub

'==============================================================
' DAO. Обработка ошибок
Private Sub butDAO_Click()
Dim dbs As DAO.Database
Dim oneErr As DAO.Error
Dim strmdb As String, s As String
    
    On Error Resume Next
    Set dbs = DBEngine.OpenDatabase("?", , 2 / 0) ' Генерируем ошибку
    'Err.Raise 11 ' Самостоятельный генератор ошибок
    
    ' Информация о всех ошибках
    s = "Список ошибок;------ DAO "  DAO.Version  " -------;"
    For Each oneErr In DBEngine.Errors
        s = s  "Описание;"  oneErr.Description  ";"
        s = s  "Номер;"  oneErr.Number  ";"
        s = s  "Имя приложения;"  oneErr.Source  ";"
    Next
    ' Полная информация о последней ошибке
    s = s  "Последняя ошибка;------ DAO -------;"
    Me.listErrors.RowSource = s  funLastError 'Отображаем ошибку
    Err.Clear
End Sub

'==============================================================
'  Возвращает информацию о последней ошибке
'  ADO и DAO
Private Function funLastError() As String
Dim s As String
    s = "Описание;"  Err.Description  ";"
    s = s  "Номер;"  Err.Number  ";"
    s = s  "Код справки;"  Err.HelpContext  ";"
    s = s  "Файл справки;"  Err.HelpFile  ";"
    s = s  "Имя приложения;"  Err.Source  ";"
    s = s  "DLL код;"  Err.LastDllError  ";"
    funLastError = s
End Function

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

Private Sub Дата_GotFocus()
    With Me.Form.Recordset
        Me.Parent.NumberRecord = .AbsolutePosition + 1
        Me.Parent.PercentPosition = .PercentPosition
        Me.Parent.RecordCount = .RecordCount
        Me.Parent.Repaint
    End With
End Sub

08. Этот пример показывает как с использованием API интерфейса и функция времени в миллисекундах с момента запуска Windows оперелить время открытия формы

' Функция времени в миллисекундах с момента запуска Windows
Private Declare Function apiTimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long
Dim T0 As Long, T1 As Long

Private Sub Form_Open(Cancel As Integer)
    ' Устанавливаем начальное значение
    T0 = apiTimeGetTime()
    ' Определяем список
    Me.myList.RowSource = Me.myList.RowSource  ";Form_Open: "  ";"  T0  ";"  0
End Sub
Private Sub Form_Activate()
    T1 = apiTimeGetTime()
    Me.myList.RowSource = Me.myList.RowSource  ";Form_Activate: "  ";"  T1  ";"  T1 - T0
End Sub
Private Sub Form_Current()
    T1 = apiTimeGetTime()
    Me.myList.RowSource = Me.myList.RowSource  ";Form_Current: "  ";"  T1  ";"  T1 - T0
End Sub
Private Sub Form_Load()
    T1 = apiTimeGetTime()
    Me.myList.RowSource = Me.myList.RowSource  ";Form_Load: "  ";"  T1  ";"  T1 - T0
End Sub
Private Sub Form_Resize()
    T1 = apiTimeGetTime()
    Me.myList.RowSource = Me.myList.RowSource  ";Form_Resize: "  ";"  T1  ";"  T1 - T0
End Sub

02. В этом примере показаны два разных метода открытия базы данных через ADO, DAO и использование файла udl

Option Compare Database
Option Explicit
'***************************************************************
' 02. Открытие базы данных разными методами
'***************************************************************

'==============================================================
' ADO. Открытие базы данных
Private Sub butADO_Click()
Dim cnn As ADODB.Connection ' Переменная для соединения
Dim myLinks As MSDASC.DataLinks ' Переменная для граф.интерфейса
   On Error GoTo 999
   ' Текущее соединение
   ' Set cnn = CurrentProject.Connection
   
   ' Определяем новое соединение
   Set cnn = New ADODB.Connection
   
   If Me.grOpen Then ' Графический интерфейс
        If Me.grOpen = 1 Then ' Графический интерфейс
         ' 1. Открытие соединения без файла
           cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
           cnn.Mode = adModeReadWrite ' Открываем на чтение и запись
           cnn.Properties("User ID") = "Admin"
           cnn.Properties("Data Source") = CodeProject.Path  "\la_form.mdb"
        Else
           ' 2. Открываем соединение, используя файл udl (2 варианта открытия)
           On Error Resume Next
           cnn.Open
           cnn.Properties("Extended Properties") = "File Name="  CodeProject.Path  "\la_ado.udl"
           ' Дополнительный пример
           ' cnn.Open "File Name="  CodeProject.Path  "\la_ado.udl"
           cnn.Close
           Err.Clear
        End If
        ' Включаем редактор udl (см. также Tools/References ...)
        Set myLinks = New MSDASC.DataLinks
        myLinks.hWnd = Application.hWndAccessApp ' Родственник udl
        If myLinks.PromptEdit(cnn) = True Then ' Редактирование, OK = true
            cnn.Open
            cnn.Close
            ' Отображаем строку подключения
            Me.listCon.RowSource = cnn.ConnectionString
        Else
            ' Отображаем пустую строку подключения
            Me.listCon.RowSource = "Отмена соединения;"
        End If
        
        Set myLinks = Nothing ' Уничтожаем ссылку
   Else ' Программный интерфейс
        ' Определяем строку соединения для Microsoft.Jet.OLEDB
        ' Полностью определить переменные подключения для других провайдеров
        ' можно открыв файл udl, который создается в проводнике
        Dim strCnn As String
        strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;" ' Провайдер
        strCnn = strCnn  "Data Source="  CurrentProject.Path  "\la_form.mdb;" ' база данных
        strCnn = strCnn  "User ID=Admin;" ' Пользователь
        strCnn = strCnn  "Mode=ReadWrite|Read;" ' Режим чтения и записи+другие свойства
        strCnn = strCnn  "Extended Properties='';" ' Расширенные свойства, например, файл udl
        strCnn = strCnn  "Persist Security Info=False;"
        strCnn = strCnn  "Locale Identifier=1033;"
        strCnn = strCnn  "Jet OLEDB:System database='';" 'C:\..\SYSTEM.MDW;
        strCnn = strCnn  "Jet OLEDB:Database Password='';" ' Пароль внутри базы
        strCnn = strCnn  "Jet OLEDB:New Database Password='';"
        strCnn = strCnn  "Jet OLEDB:Encrypt Database=False;"
        strCnn = strCnn  "Jet OLEDB:Create System Database=False;"
        strCnn = strCnn  "Jet OLEDB:Registry Path='';"
        strCnn = strCnn  "Jet OLEDB:Engine Type=5;"
        strCnn = strCnn  "Jet OLEDB:Database Locking Mode=1;"
        strCnn = strCnn  "Jet OLEDB:Global Partial Bulk Ops=2;"
        strCnn = strCnn  "Jet OLEDB:Global Bulk Transactions=1;"
        strCnn = strCnn  "Jet OLEDB:Don't Copy Locale on Compact=False;"
        strCnn = strCnn  "Jet OLEDB:SFP=False;"
        strCnn = strCnn  "Jet OLEDB:Compact Without Replica Repair=False;"
        
        ' Назначаем строку соединения
        cnn.ConnectionString = strCnn
        
        ' Отображаем строку подключения
        Me.listCon.RowSource = cnn.ConnectionString
        
        ' Открываем соединение
        cnn.Open
        cnn.Close
End If
    ' Конец
    Set cnn = Nothing
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
' DAO. Открытие базы данных
Private Sub butDAO_Click()
Dim dbs As DAO.Database
    ' Текущая база
    ' Set dbs = CurrentDb
    
    ' Открываем новую базу
    Set dbs = DBEngine.OpenDatabase(CurrentProject.Path  "\la_form.mdb", , True)
    ' Отображаем строку подключения
    Me.listCon.RowSource = "DAO"
    
    ' Закрываем базу
    dbs.Close
    Set dbs = Nothing
    MsgBox "База открыта и закрыта (DAO)!", vbExclamation, "Лидер Access"
End Sub

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

Option Compare Database
Option Explicit

'Функция нечеткого сравнения строк, смотрите применение в
'форме: Example 03
'
'метод предложен Кива Владимир vlak@glasnet.ru
'http://www.glasnet.ru/~vlak/similar/similar.html
'
'Программирование: Николай Малютин, malnik@mail.ru
'
'lngMaxLen - максимальная длина подстроки (достаточно 3-4)
'strStringMatching - сравниваемая строка
'strStringStandart - строка-образец
'

Private Type RetCount
    lngSubRows As Long
    lngCountLike As Long
End Type

Public Function IndistinctMatching(lngMaxLen As Long, strStringMatching As String, strStringStandart As String, lngCase As Long) As Long
Dim gret As RetCount
Dim tret As RetCount
Dim lngCurLen As Long   'текущая длина подстроки

    'если не передан какой-либо параметр, то выход
    If lngMaxLen = 0 Or Len(strStringMatching) = 0 Or Len(strStringStandart) = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    
    gret.lngCountLike = 0
    gret.lngSubRows = 0
    For lngCurLen = 1 To lngMaxLen
        'Сравниваем строку A со строкой B
        tret = MatchingStrings(strStringMatching, strStringStandart, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
        'Сравниваем строку B со строкой A
        tret = MatchingStrings(strStringStandart, strStringMatching, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
    Next lngCurLen
    
    If gret.lngSubRows = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    IndistinctMatching = (gret.lngCountLike / gret.lngSubRows) * 100
End Function

Private Function MatchingStrings(strA As String, strB As String, lngLen As Long, lngCase As Long) As RetCount
Dim tret As RetCount
Dim y As Long, z As Long
Dim strta As String
Dim strtb As String
    For z = 1 To Len(strA) - lngLen + 1
       strta = Mid(strA, z, lngLen)
       y = 1
       For y = 1 To Len(strB) - lngLen + 1
          strtb = Mid(strB, y, lngLen)
          If StrComp(strta, strtb, lngCase) = 0 Then
          tret.lngCountLike = tret.lngCountLike + 1
          Exit For
          End If
       Next y
    tret.lngSubRows = tret.lngSubRows + 1
    Next z
    MatchingStrings.lngCountLike = tret.lngCountLike
    MatchingStrings.lngSubRows = tret.lngSubRows
End Function

02. Есть таблица, в ней нужно провести поиск по нескольким полям. При этом задача должна решаться так, ввели 1 символ, таблица изменилаяь и показала все записи, где есть эта фраза

Option Compare Binary
Option Explicit
'Option Compare Text

'***************************************************************
' 3. Пример. Как создать контекстный поиск в Access
'   (смотрите также пример 2) ?
'***************************************************************

'==============================================================
' Открытие формы
Private Sub Form_Open(Cancel As Integer)
    Me.myFind3.Form.RecordSource = "SELECT Книга FROM [1-Мои книги]"
End Sub

'==============================================================
' Поиск с отбором книг
Private Sub myBooks_Change()
Dim s As String
    s = Me.myBooks.Text 'Определяем текст
    With Me.myFind3.Form 'Выбираем форму
      If Len(s)  0 Then
        s = " WHERE Left([Книга],"  Len(s)  ") = '"  s  "'"
      Else
        s = ";"
      End If
      .RecordSource = "SELECT Книга FROM [1-Мои книги]"  s
      .Requery 'Меняем запрос
    End With
End Sub

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

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

Private Sub Report_Open(Cancel As Integer)
    Me.RecordSource = "SELECT * From Cправочник WHERE [Цена]50"
End Sub

19. Можно создать два разных отчета, а для их объединения использовать Главный отчет. При его открытии можно изменить вид отчета, если поменять источник. Смотрите этот пример.

Private Sub Report_Open(Cancel As Integer)
    If MsgBox("Изменить поля отчета?", vbInformation + vbOKCancel) = vbOK Then
        Me.subReport.SourceObject = "Отчет.Пример 19_sub2"
    End If
End Sub

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

Dim cnt As Long ' Число записей

'===============================================================
' Обнуляем информацию по отчету
Private Sub Report_Open(Cancel As Integer)
    cnt = 0
End Sub

'===============================================================
' Считаем данные
Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
Dim rpt As Report
    On Error GoTo 999
    'Находим в запросе нужную запись
    cnt = cnt + 1
    Me.CountRpt.Caption = Me.Page  "/"  cnt
    Exit Sub
999:
    Err.Clear
End Sub

' Печатаем информацию для каждого колонтитула
Private Sub ВерхнийКолонтитул_Format(Cancel As Integer, FormatCount As Integer)
    Me.headpage.Caption = "Страница: "  Me.Page  "/"  cnt
End Sub

18. У меня в отчете несколько листов. Приходится общую сумму листа считать вручную. Общую сумму отчета делать умею, но вот каждого листа в отдельности нет. Этот небольшой пример решает такую задачу.

Private sumPage As Currency, strMsg As String

Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
    sumPage = Me.Цена.Value + sumPage
    strMsg = strMsg  Me.Пункт  ".  "  Me.Цена.Value  vbNewLine
End Sub

Private Sub НижнийКолонтитул_Format(Cancel As Integer, FormatCount As Integer)
    Me.PageИтого.Value = sumPage
    MsgBox strMsg
    sumPage = 0
    strMsg = ""
End Sub