24. Если у вас в форме используется несколько таблиц, то связать их можно с помощью этого программного кода
Public Sub Form_Current()
On Error GoTo 999
With Me.Parent.Пример_24_2.Form
.Filter = "Код=" Me.Код
.FilterOn = True
End With
Exit Sub
999:
Err.Clear
End Sub
05. Открыть запросы SELECT базы данных можно по разному. Эти функции показывают, как можно это сделать из разных библиотек.
Файлы находятся в папке 16. Модули
Option Compare Database
Option Explicit
'==============================================================
' 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 = "SELECT * from [Пример 04]"
.Open , CurrentProject.Connection, , , adCmdText
If rst.RecordCount Then
.MoveLast ' Заполнение запроса и расчет кол-ва записей
.MoveFirst ' Начнем с первой записи
Do Until .EOF
' Изменение записей
rst!Описание = "ADO. Пример 05"
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
Dim i As Long
' Включаем обработку ошибок
On Error GoTo 999
' Создание запроса
Set dbs = CurrentDb ' Текущая база данных
Set rst = dbs.OpenRecordset("SELECT * from [Пример 04]")
' Заполняем запрос
With rst
If .RecordCount Then
.MoveLast ' Заполнение запроса и расчет кол-ва записей
.MoveFirst ' Начнем с первой записи
For i = 0 To .RecordCount - 1
' Редактирование записей
rst.Edit
rst!Описание = "DAO. Пример 05"
rst.Update
rst.MoveNext
Next
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
02. Есть таблица, в ней нужно провести поиск по нескольким полям. При этом задача должна решаться так, ввели 1 символ, таблица изменилаcь и показала все записи, где есть эта фраза (..\15 Формы\la_from.accdb\03. Контекстный поиск)
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
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
Для быстрой загрузки всех файлов в таблицу можно использовать этот способ. Применяйте его, например, для обработки html файлов
' При загрузке формы загружаем файлы
Private Sub Form_Load()
funAutoReadAllFiles Application.CurrentProject.Path, "*.txt"
End Sub
' Прочитаем имена файлов и загрузим их в таблицу
Private Sub funAutoReadAllFiles(strDir As String, strFileExt As String)
Dim i As Long, rst As DAO.Recordset
On Error GoTo 999
With Application.FileSearch
.NewSearch
.LookIn = strDir ' *.name
.FILENAME = strFileExt ' *.txt
.SearchSubFolders = False
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) 0 Then
For i = 1 To .FoundFiles.Count
If MsgBox("Загрузить файл: " .FoundFiles(i), vbInformation + vbOKCancel, "Загрузить") = vbOK Then
funAutoReadOneFile .FoundFiles(i), "Таблица5"
Me.table5.Requery
End If
Next i
End If
End With
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
' Загружаем файл в таблицу
Private Function funAutoReadOneFile(strFileName As String, strTable)
Dim fs, f, flag
Dim dbs As DAO.Database, rst As DAO.Recordset
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFileName)
' Проверка файла
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("select * from " strTable)
If rst.RecordCount Then
rst.MoveLast
rst.MoveFirst
End If
rst.FindFirst "[FileName] = '" strFileName "'"
If rst.NoMatch = False Then
dbs.Close
rst.Close
Exit Function
End If
' Добавление информации о дате создания
rst.AddNew
rst!FILENAME = strFileName
rst!DateCreated = f.DateCreated
' Добавление информации о содержимом
rst!Memo = ""
Set f = fs.OpenTextFile(strFileName, 1, False)
Do While f.AtEndOfStream True
rst!Memo = rst!Memo f.ReadLine ' Читаем построчно
Loop
f.Close
' Сохранение содержимого
rst.Update
rst.Close
dbs.Close
Exit Function
999:
'Ошибка:
MsgBox Err.Description
Err.Clear
rst.Close
End Function
04. Данный пример показывает как можно создать таблицу в Microsoft Word, используя vba в Word. При этом создается соединение внутри документа Word. Обратите внимание, что функция InsertDatabase отличается параметрами в разных версиях офиса.
Option Compare Database
Option Explicit
'#Const AccessVer = 2000
'#Const AccessVer = 2002
#Const AccessVer = 2003
'***************************************************************
'04.Пример. Как создать таблицу в документе Word ?
'***************************************************************
'==============================================================
' Создание таблицы в документе Word
' ---------------------------------
' Для этого Вы должны создать в шаблоне la_automat.dot
' закладку с имеенем Таблица. Например,
' Вставка - Закладка ... - Имя закладки=Таблица
' (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application 'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim strMDB As String ' Имя базы данных
Dim rng As Word.Range ' Область данных
Dim tbl As Word.Table ' Таблица документа
Dim c As Word.Cell ' Ячейка таблицы
Dim i As Long ' Переменная
On Error GoTo 999
' Определяем имена шаблона, документа и базы данных
With Application.CurrentProject
strDOT = .Path "\" "la_automat.dot"
strDOC = .Path "\" "la_automat.doc"
strMDB = .Path "\" .Name
End With
' Управление документом Word
Set app = New Word.Application 'Новое приложение Word
app.Visible = True 'Отображаем документ
app.Documents.Add strDOT 'Добавляем шаблон
' Выбираем закладку (позицию) таблицы
Set rng = app.ActiveDocument.Bookmarks("Таблица").Range
With rng
.Collapse wdCollapseEnd
' Вставляем таблицу, используя запрос из базы данных
#If AccessVer = 2000 Then
.InsertDatabase _
Style:=191, _
LinkToSource:=False, _
Connection:="Query ЗапросПримера04", _
DataSource:=strMDB
#ElseIf AccessVer = 2002 Then
.InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" strMDB ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engi" _
, SQLStatement:="SELECT * FROM `ЗапросПримера04`" "", PasswordDocument _
:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", DataSource:= _
strMDB, From:=-1, To:=-1, _
IncludeFields:=True
#Else
.InsertDatabase Format:=0, Style:=0, LinkToSource:=False, _
Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=" strMDB ";Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLE" _
, SQLStatement:="SELECT * FROM `ЗапросПримера04`" "", PasswordDocument _
:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", DataSource:= _
strMDB, From:=-1, To _
:=-1, IncludeFields:=True
#End If
i = .Tables.Count ' Всего таблиц в данной области
Set tbl = .Tables(i) ' Созданная таблица
' Форматируем всю таблицу
tbl.Range.Font.Size = 10 ' Выбираем шрифт
tbl.AutoFormat wdTableFormatGrid8 ' Выбираем авто-формат
' Вставляем колонку в начало таблицы
tbl.Columns.Add tbl.Columns(1) ' Добавляем колонку
i = 0
For Each c In tbl.Range.Columns(1).Cells
If i Then
' Изменяем данные
c.Range.InsertAfter Format(i, "000") ' Вставить данные
c.Range.ParagraphFormat.Alignment = wdAlignParagraphRight 'Правый формат
Else
' Изменяем заголовок ячейки
tbl.Range.Columns(1).Cells(1).Range.Text = "Пункт"
End If
i = i + 1
Next c
' Форматируем заголовок, т.е. всю строку
tbl.Rows(1).Select ' Выбираем заголовок
With app.Selection
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Font.Name = "Arial" ' Имя шрифта
.Font.Size = 10 ' Размер шрифта
End With
' Добавляем новую строку
tbl.Rows.Add ' Добавляем строку в конец таблицы
With tbl.Cell(tbl.Rows.Count, 1) ' Выбираем 1 ячейку строки
.Formula "=SUM(ABOVE)" ' Устанавливаем формулу
.Shading.BackgroundPatternColorIndex = wdDarkRed ' Назначаем цвет фона
.Range.Font.Bold = True ' Толщина (вес) текста
End With
End With
app.ActiveDocument.SaveAs strDOC ' Сохраняем файл
' app.Quit 'Закрываем приложение
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
app.Quit
End Sub
Сторнирование - это возврат денежных средств, отображается красным цветом. Смотрите как это можно сделать из VBA (..\15 Формы\la_from.accdb\01. Сторнирование бухгалтерских операций)
With [Form_Пример 01 пдч].Сумма
.Format = "0.00;0.00[Red]" 'Красный цвет в поле
End With
21. Это достаточно гибкий способ менять источник данных в вашей форме. Он не использует строковые переменные, а применяет ключевое слово set для запроса данных из DAO или ADO.
Private Sub Form_Open(Cancel As Integer)
Me.Дата = DateSerial(2005, 9, 20)
butDAOrecordset_Click
End Sub
Private Sub Дата_AfterUpdate()
butDAOrecordset_Click
End Sub
Private Sub butADOrecordset_Click()
Dim rst As ADODB.Recordset
' Создание запроса
Set rst = New ADODB.Recordset
' Заполняем запрос
With rst
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = "[Мои книги]"
.Open , CurrentProject.Connection, , , adCmdTable
End With
Set Me.subForm.Form.Recordset = rst
End Sub
Private Sub butDAOrecordset_Click()
Dim strParm As String, strSQL As String
Dim qry As DAO.QueryDef, dbs As DAO.Database
Set dbs = CurrentDb
Set qry = dbs.QueryDefs("qryExample22")
qry.Parameters("paramДата") = Nz(Me.Дата, Date)
Set Me.subForm.Form.Recordset = qry.OpenRecordset
' strParm = "PARAMETERS [paramДата] DATETIME; "
' strSQL = strParm "SELECT * FROM [Мои книги] WHERE [Дата]=[paramДата]"
' Me.Список.Form.InputParameters = "paramДата DateTime=#09/20/2000#"
End Sub
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
21. Используя ссылку на подчиненную форму, можно автоматически вычислять итоги в главной форме.
Private Sub Form_Load()
Me.Сумма.ControlSource = "=[Список].Form![ИтоговаяСумма]"
End Sub