Данный пример определяет коды клавиш меню для быстрого запуска команд. Например, чтобы вызвать пункт меню "Сервис\Схема данных" достаточно запустить команду: CommandBars("Menu Bar").FindControl(, 523, , , True).Execute или CommandBars("Tools").Controls("С&хема данных...").Execute
Private Sub myBar_AfterUpdate()
' Гасим все меню
On Error Resume Next
Dim cbr As CommandBar
For Each cbr In Application.CommandBars
If cbr.Visible Then cbr.Visible = False
Next
Err.Clear
On Error GoTo 999
' Удаляем все из базы данных
Dim dbs As Database
Set dbs = CurrentDb 'Выбор базы данных
dbs.Execute "DELETE * FROM [Пример 05]" 'Удаляем все записи
Me.myControlsBar.Requery
' Находим панель
Set cbr = Application.CommandBars(Me.myBar.Value) ' Выбираем меню
cbr.Visible = True
' Просматриваем панель
Dim cbc As CommandBarControl
For Each cbc In cbr.Controls ' Просматриваем все кнопки
putControlsBar cbc.Parent.Name, cbc ' Сохраняем кнопку
Next
' Перерисовываем форму
Me.myControlsBar.Requery
Me.txtMsg.Visible = False ' Гасим сообщение
Exit Sub
999:
MsgBox Err.Description
Err.Clear
End Sub
Private Function putControlsBar(strParent As String, obj As Object)
Dim cbc As CommandBarControl, s As String
If TypeOf obj Is CommandBarPopup Then
' Меню. Сохраняем каждую кнопку меню
For Each cbc In obj.CommandBar.Controls
s = strParent "\" cbc.Parent.Name
putControlsBar s, cbc
Next cbc
Else
' Кнопка. Добавляем ее в таблицу
InsertString strParent, obj.Caption, obj.ID
End If
End Function
'==============================================================
' Вставляем строку в базу данных
Private Function InsertString(strParent As String, strCaption As String, longID As Long)
Dim s As String, dbs As Database, strCommand As String
On Error Resume Next
Set dbs = CurrentDb 'Выбор базы данных
strCommand = "CommandBars(""""Menu Bar"""").FindControl(, " longID ", , , True).Execute"
s = "INSERT INTO [Пример 05] ( Parent, Name, ID, Command ) SELECT """ _
strParent """ AS Parent, """ _
strCaption """ AS Name," _
longID " AS ID, """ _
strCommand """ AS Command;"
dbs.Execute s 'Добавляем в таблицу код кнопки
Debug.Print s
Err.Clear
' Сообщаем о работе программы
DoEvents
Me.txtMsg.Visible = Not Me.txtMsg.Visible ' Сообщение
End Function
'==============================================================
' Отобразить схему базы данных
' (выберите код кнопки и запустите программу)
Private Sub butTools_Click()
Dim cbc As CommandBarControl
' 1 вариант. Запуск по названию
'CommandBars("Tools").Controls("Схема данных...").Execute
' 2 вариант. Поиск по коду и проверка для запуска
'Set cbc = CommandBars("Menu Bar").FindControl(ID:=523, Recursive:=True)
'If cbc.Visible Then cbc.Execute
' 3 вариант. Поиск и запуск по коду
CommandBars("Menu Bar").FindControl(, 523, , , True).Execute
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
Если Вам необходимо сформировать динамический (быстрый) просмотр данных, то имеет смыл у отчета вообще не указывать запрос. А при открытии его вызвать например форму и изменить его отображение. В примере, показано как установить фильтр для источник записи (08 Отчеты\la_report1.accdb. 20. Изменение запроса отчета).
Private Sub Report_Open(Cancel As Integer)
Me.RecordSource = "SELECT * From Cправочник WHERE [Цена]50"
End Sub
13. Если Вы разрабатываете интерфейс в зависимости от разных ролей пользователей, которым нужно разрешить или запретить редактирование формы, то используйте этот пример.
Private Sub butEdit_Click()
Dim frm As Form
Set frm = [Form_Пример 13 пдч]
frm.AllowAdditions = Me.butEdit 'Разрешить добавление
frm.AllowDeletions = Me.butEdit 'Разрешить удаление
frm.AllowEdits = Me.butEdit 'Разрешить редактирование
If Me.butEdit = True Then 'Если разрешено редактирование
Me.butEdit.Caption = "Отменить редактирование" 'Текст кнопки
Me.butEdit.ForeColor = 255 'Цвет символов
Else
Me.butEdit.Caption = "Включить редактирование"
Me.butEdit.ForeColor = 0
End If
End Sub
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
Для быстро�� загрузки всех файлов в таблицу можно использовать этот способ. Применяйте его, например, для обработки 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
Сторнирование - это возврат денежных средств, отображается красным цветом. Смотрите как это можно сделать из VBA (..\15 Формы\la_from.accdb\01. Сторнирование бухгалтерских операций)
With [Form_Пример 01 пдч].Сумма
.Format = "0.00;0.00[Red]" 'Красный цвет в поле
End With
21. Используя ссылку на подчиненную форму, можно автоматически вычислять итоги в главной форме.
Private Sub Form_Load()
Me.Сумма.ControlSource = "=[Список].Form![ИтоговаяСумма]"
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
07. Это пример необходим для того, чтобы использовать клавиатуру в ваших разработках. Обратите внимание какой код передает кнопка на клавиатуре для разных языков.
Option Compare Database
Option Explicit
'==============================================================
' Нажать клавишу клавиатуры
Public Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyF1 '0x70 F1 ключ
Case vbKeyF2 '0x71 F2 ключ
Case vbKeyF3 '0x72 F3 ключ
Case vbKeyF4 '0x73 F4 ключ
Case vbKeyF5 '0x74 F5 ключ
Case vbKeyF6 '0x75 F6 ключ
Case vbKeyF7 '0x76 F7 ключ
Case vbKeyF8 '0x77 F8 ключ
Case vbKeyF9 '0x78 F9 ключ
Case vbKeyF10 '0x79 F10 ключ
Case vbKeyLButton '0x1 Левая клавиша мыши
Case vbKeyRButton '0x2 Правая клавиша мыши
Case vbKeyCancel '0x3 CANCEL ключ
Case vbKeyMButton '0x4 Средняя клавиша мыши
Case vbKeyBack '0x8 BACKSPACE ключ
Case vbKeyTab: '0x9 TAB ключ
Case vbKeyClear '0xC CLEAR ключ
Case vbKeyReturn '0xD ENTER ключ
Case vbKeyShift '0x10 SHIFT ключ
Case vbKeyControl '0x11 CTRL ключ
Case vbKeyMenu '0x12 MENU ключ
Case vbKeyPause '0x13 PAUSE ключ
Case vbKeyCapital '0x14 CAPS LOCK ключ
Case vbKeyEscape '0x1B ESC ключ
Case vbKeySpace '0x20 SPACEBAR ключ
Case vbKeyPageUp '0x21 PAGE UP ключ
Case vbKeyPageDown '0x22 PAGE DOWN ключ
Case vbKeyEnd '0x23 END ключ
Case vbKeyHome '0x24 HOME ключ
Case vbKeyLeft '0x25 LEFT ARROW ключ
Case vbKeyUp '0x26 UP ARROW ключ
Case vbKeyRight '0x27 RIGHT ARROW ключ
Case vbKeyDown '0x28 DOWN ARROW ключ
Case vbKeySelect '0x29 SELECT ключ
Case vbKeyPrint '0x2A PRINT SCREEN ключ
Case vbKeyExecute '0x2B EXECUTE ключ
Case vbKeySnapshot '0x2C SNAPSHOT ключ
Case vbKeyInsert '0x2D INSERT ключ
Case vbKeyDelete '0x2E DELETE ключ
Case vbKeyHelp '0x2F HELP ключ
Case vbKeyNumlock '0x90 NUM LOCK ключ
Case Else
'MsgBox "Другой ключ"
End Select
Me.myKey.Caption = "Код кнопки клавиатуры: " Format(KeyCode, "000")
Me.myShift.Caption = "Код кнопки Shift: " Format(Shift, "000")
Me.myXY.Caption = "Координаты: -"
'Обнулить данные, чтобы не работали клавиши
'и другие "Alt-", "F1" и т.п.
KeyCode = 0
Shift = 0
End Sub
'==============================================================
' Открытие модуля
Private Sub butVBA_Click()
DoCmd.OpenModule Me.Module
End Sub
'==============================================================
' Загрузка формы
Private Sub Form_Load()
Me.KeyPreview = True 'Включить обработку клавиатуры
End Sub
'==============================================================
' Нажатие клавиши мыши
Private Sub Пример_7_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
Select Case Button
Case acLeftButton
Case acRightButton
Case acMiddleButton
End Select
Select Case Shift
Case acShiftMask
Case acCtrlMask
Case acAltMask
End Select
Me.myKey.Caption = "Кнопка мыши: " Format(Button, "000")
Me.myShift.Caption = "Код кнопки Shift: " Format(Shift, "000")
Me.myXY.Caption = "Координаты мыши в твипах: X=" X ", Y=" y
End Sub
'==============================================================
' Передвинуть мышь
Private Sub Пример_7_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
Пример_7_MouseDown Button, Shift, X, y
End Sub