04. Открыть таблицы базы данных можно по разному. Эти функции показывают, как можно это сделать из разных библиотек.
'==============================================================
' ADO. Использование таблиц
Private Sub butADO_Click()
Dim rst As ADODB.Recordset
' Включаем обработку ошибок
On Error GoTo 999
' Создание запроса
Set rst = New ADODB.Recordset
' Заполняем запрос
With rst
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = "[Пример 04]"
.Open , CurrentProject.Connection, , , adCmdTable
If rst.RecordCount Then
.MoveLast ' Заполнение запроса и расчет кол-ва записей
.MoveFirst ' Начнем с первой записи
Do Until .EOF
' Изменение записей
rst!Описание = "ADO. Пример 04"
rst.Update
rst.MoveNext
Loop
End If
End With
' Отображаем список
Me.myList.RowSource = "ADODB. Изменение сделаны;Всего записей: " Format(rst.RecordCount, "000")
' Конец просмотра
rst.Close
Set rst = Nothing
Exit Sub
999:
MsgBox Err.Description
Err.Clear
End Sub
'==============================================================
' DAO. Использование таблиц
Private Sub butDAO_Click()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
' Включаем обработку ошибок
On Error GoTo 999
' Создание запроса
Set dbs = CurrentDb ' Текущая база данных
Set rst = dbs.OpenRecordset("Пример 04", dbOpenTable)
' Заполняем запрос
With rst
If .RecordCount Then
.MoveLast ' Заполнение запроса
.MoveFirst ' Начнем с первой записи
Do Until .EOF
' Изменение записей
rst.Edit
rst!Описание = "DAO. Пример 04"
rst.Update
rst.MoveNext
Loop
End If
End With
' Отображаем список
Me.myList.RowSource = "DAO. Изменения сделаны;Всего записей: " Format(rst.RecordCount, "000")
' Конец просмотра
rst.Close
Set rst = Nothing
Set dbs = Nothing
Exit Sub
999:
MsgBox Err.Description
Err.Clear
End Sub
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
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
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. Есть таблица, в ней нужно провести поиск по нескольким полям. При этом задача должна решаться так, ввели 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
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
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
20. Если Вам необходимо сформировать динамический (быстрый) просмотр данных, то имеет смыл у отчета вообще не указывать запрос. А при открытии его вызвать например форму и изменить его отображение. В примере, показано как установить фильтр для источник записи.
Private Sub Report_Open(Cancel As Integer)
Me.RecordSource = "SELECT * From Cправочник WHERE [Цена]50"
End Sub