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
07. Этот пример показывает, как в Access можно заполнить файл Excel разными способами: 1) Заполнение каждой ячейки своим значением 2) Заполнение ячеек из массива 3) Заполнение несколько ячеек 1 значением 4) Заполнение ячеек из ADODB.Recordset
'***************************************************************
' Подписка: "Access - программирование и готовые решения"
' Тема: "Клиенты автоматизации Access"
' Версия: 1 от 16.07.2009
' Автор: Copyright © Leader Access, Ltd
' Сайт: http://www.leadersoft.ru
'***************************************************************
' 07. Пример. Вывод информации в Excel
' Записывается информация о книгах по строкам,
' используя разные варианты: Название, Цена, Автор, Пункт
'***************************************************************
Private Sub butOK_Click()
On Error GoTo 999
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlFileName As String
' Определяем и проверяем имя файла
xlFileName = Application.CurrentProject.Path "\Книги.xls"
If Dir(xlFileName, vbNormal) = "" Then
MsgBox "Файл не найден: " xlFileName, vbCritical, "http://www.leadersoft.ru"
Exit Sub
End If
' Устанавливаем ссылку на страницу
Set xlApp = CreateObject("Excel.Application") ' Открываем Excel
Set xlBook = xlApp.Workbooks.Open(FileName:=xlFileName) ' Открываем файл
Set xlSheet = xlBook.Sheets("Мои книги") ' Выбираем лист книги
xlApp.Visible = True ' Отображаем Excel
' Записываем данные в ячейки, пропустив строку заголовка
' 1 вариант. Сохраняем 1 значение ( 2 строка данных )
xlSheet.Range("A2").Value = "Война и мир"
xlSheet.Range("B2").Value = "200"
xlSheet.Range("C2").Value = "Толстой"
' 2 вариант. Используем массив ( 3 строка данных )
xlSheet.Range(xlSheet.Cells(3, 1), xlSheet.Cells(3, 3)).Value = _
Array("Горе от ума", "150", "Грибоедов")
' 3 вариант. Используем одно значение ( Нумерация строк на листе )
xlSheet.Range(xlSheet.Cells(2, 4), xlSheet.Cells(6, 4)).FormulaR1C1 = "=ROW()-1"
' 4 вариант. Используем запрос из базы данных ( 5 и 6 строка данных )
Dim cn As ADODB.Connection, rs As New ADODB.Recordset, SQL As String
Set cn = Application.CurrentProject.Connection
SQL = "SELECT Книга,Сумма,Автор FROM [Пример 04] WHERE Len([Автор]) 0"
rs.Open SQL, cn
xlSheet.Range("A5").CopyFromRecordset rs
rs.Close
Set rs = Nothing
' --- Закрываем Excel и уничтожаем объекты, если это необходимо сделать автоматически ---
' xlBook.Close SaveChanges:=True
' xlApp.Quit
' Set xlSheet = Nothing
' Set xlBook = Nothing
' Set xlApp = Nothing
Exit Sub
999:
MsgBox Err.Description, vbCritical, "http://www.leadersoft.ru"
Err.Clear
End Sub
02. Данный пример показывает как можно быстро создать документ Word из Microsoft Access. При этом документ будет создаваться в текущей папке, откуда запущено приложение. Также не забудьте создать ссылку на Word: C:\Program Files\Microsoft Office\OFFICE11\MSWORD.OLB
'==============================================================
' Назначение
' Создать документ Word в текущей папке
'
Private Sub butExecute_Click()
Dim app As Word.Application ' Приложение программы
Dim strDOC As String ' Имя файла
On Error GoTo 999
' Назначаем имя документа
strDOC = Application.CurrentProject.Path "\" "la_automat.doc"
Set app = New Word.Application ' Создаем документ
app.Visible = False ' Скрываем документ
app.Documents.Add ' Добавляем документ
app.Selection.Text = Me.Body ' Вставляем текст
app.ActiveDocument.SaveAs strDOC ' Сохраняем документ
app.Quit ' Закрываем документ
MsgBox "Файл: " strDOC " создан!", vbExclamation, "Документ Word"
' Назначение ссылки
With Me.myWordDoc
.HyperlinkAddress = strDOC ' Создаем ссылку
.Visible = True ' Отображаем элемент
End With
Exit Sub
999:
MsgBox Err.Description ' Ошибка
Err.Clear
app.Quit
End Sub
05. Данный пример показывает, как можно создать папки в Outlook. В качестве примера загрузки берется Outlook Express с файлами dbx
'==============================================================
' Создание папок с использованием Outlook
Private Sub butExecute_Click()
Dim app As Outlook.Application 'Приложение программы
Dim i As Integer 'Счетчик
Dim myNamespace, myfolder As MAPIFolder, mynewfolder
On Error GoTo 999
Set app = New Outlook.Application
Set myNamespace = app.GetNamespace("MAPI")
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
With Application.FileSearch
.NewSearch
.LookIn = Me.myFolderInternetExpress ' = c:\
.FileName = "*.dbx" ' Выбираем файлы для Outlook Express
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) 0 Then
Me.Progress = "Count=" .FoundFiles.Count vbCrLf
Dim strFile As String
For i = 1 To .FoundFiles.Count
strFile = fGetFileName(.FoundFiles(i))
Me.Progress = Me.Progress strFile vbCrLf
Set mynewfolder = myfolder.Folders.Add(strFile)
DoEvents
Next i
End If
End With
app.Quit 'Закрываем Outlook
MsgBox "Папки созданы!", vbExclamation, "Почта"
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
Resume Next
End Sub
Public Function fGetFileName(strPath As String) As String
Dim fs
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject")
fGetFileName = fs.GetBaseName(strPath)
Set fs = Nothing
Exit Function
999:
MsgBox Err.Description, vbCritical, strPath
Err.Clear
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
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
03. Данный пример показывает как можно быстро создать документ Word из Microsoft Access, используя шаблон *.dot. Для разметки документа используются специальные закладки.
'==============================================================
' Создание документа Word по шаблону
' • Для этого Вы должны создать в Word шаблон la_automat.dot
' и поставить в нем Закладки, имеющие такие же имена как в форме.
' Например, Вставка - Закладка ... - Имя закладки=Фирма
' (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application 'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim ctl As Control ' Управляющие элементы в форме
Dim s As String ' Вспомогательная строка
On Error GoTo 999
' Определяем имена шаблона и документа Word
With Application.CurrentProject
strDOT = .Path "\" "la_automat.dot"
strDOC = .Path "\" "la_automat.doc"
End With
' Управление документом Word
Set app = New Word.Application 'Новое приложение Word
app.Visible = True 'Отображаем документ
app.Documents.Add strDOT 'Добавляем шаблон
With app.ActiveDocument 'Выбираем активный документ
On Error Resume Next ' Отключаем ошибки
' Просматриваем все элементы формы, если
' такой закладки нет, то очищаем поток от ошибки
For Each ctl In Me.Controls
If ctl.ControlType = acTextBox Then
s = ctl.Name ' Определяем название элемента
.Bookmarks.Item(s).Range.Text = Me(s) 'Устанавливаем текст
Err.Clear ' Очищаем поток от ошибки при отсутствии элемента
End If
Next ctl
.SaveAs strDOC ' Сохраняем файл
On Error GoTo 999 ' Включаем обработку ошибки
End With
' app.Quit 'Закрываем приложение
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
app.Quit
End Sub