Есть таблица, в ней нужно провести поиск по нескольким полям. При этом одно поле зависит от другого. Как это сделать указано в это примере (..\15 Формы\la_from.accdb\02. Поиск по нескольким полям).
'==============================================================
' Поиск по дате
Private Sub Дата_AfterUpdate()
Dim rst As Recordset, frm As Form
On Error GoTo 999
Set frm = Me.формаПоиск.Form 'Выбираем форму
Set rst = frm.RecordsetClone 'Выбираем таблицу
rst.FindFirst "([Дата]=#" Format(Me.Дата, "mm\/dd\/yyyy") "#)"
If rst.NoMatch = False Then
frm.Bookmark = rst.Bookmark
Me.Книга = rst!Книга
Else
MsgBox "Нет данных!"
End If
Exit Sub
999:
MsgBox Err.Description vbNewLine "Введите правильно данные?"
End Sub
'==============================================================
' Начать поиск после обновления
Private Sub Книга_AfterUpdate()
recordFind
End Sub
'==============================================================
' Поиск по дате и книге
Private Sub recordFind()
Dim rst As Recordset, frm As Form, s As String
On Error GoTo 999
Set frm = Me.формаПоиск.Form 'Выбираем форму
Set rst = frm.RecordsetClone 'Выбираем таблицу
s = "([Дата]=#" Format(Me.Дата, "mm\/dd\/yyyy") _
"#) and (Книга='" Me.Книга "')"
rst.FindFirst s
If rst.NoMatch = False Then
frm.Bookmark = rst.Bookmark
Else
MsgBox "Нет данных!"
End If
Exit Sub
999:
MsgBox "Введите правильно данные?"
End Sub
'==============================================================
' Поиск по шаблону
Private Sub Шаблон_AfterUpdate()
Dim rst As Recordset, frm As Form, s As String
On Error GoTo 999
Set frm = Me.формаПоиск.Form 'Выбираем форму
Set rst = frm.RecordsetClone 'Выбираем таблицу
rst.FindFirst "([Книга] Like '" Me.Шаблон "')=True"
If rst.NoMatch = False Then
frm.Bookmark = rst.Bookmark
Else
MsgBox "Нет данных!"
End If
Exit Sub
999:
MsgBox "Введите правильно данные?"
End Sub
'==============================================================
' Запрос по книге
Private Sub Книга_Enter()
Me.Книга.RowSource = "SELECT Книга FROM [1-Мои книги] WHERE (((Дата)=[Forms]![Example 01]![Дата]));"
'Me.Книга.Requery 'Изменить запрос
End Sub
Этот пример покажет Вам как правильно определить различные свойства папок в Windows. Вы также сможете прочитать свойства томов, системных папок и т.п.
' Прочитать все свойства папки
' f1.DateCreate - дата создания папки
'
Private Sub butProperties_Click()
On Error GoTo 999
Dim fs, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f1 = fs.GetFolder(Me.myFolder)
Me.progress = _
"Name: " f1.Name vbCrLf _
"Path: " f1.Path vbCrLf _
"Attributes: " f1.Attributes vbCrLf _
"DateCreated: " f1.DateCreated vbCrLf _
"LastAccessed: " f1.DateLastAccessed vbCrLf _
"LastModified: " f1.DateLastModified vbCrLf _
"IsRootFolder: " f1.IsRootFolder vbCrLf _
"ShortName: " f1.ShortName vbCrLf _
"ShortPath: " f1.ShortPath vbCrLf _
"Size: " f1.Size vbCrLf _
"Type: " f1.Type vbCrLf _
"fs.FolderExists('c:\')=" fs.FolderExists("c:\") vbCrLf _
""
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
' Получение имени специальной папки
' fs.GetSpecialFolder(0) - 'c:\windows'
' fs.GetSpecialFolder(1) - 'c:\windows\system'
' fs.GetSpecialFolder(2) - 'c:\windows\temp
' Получение других имен
' fs.GetFolder(".") - текущая папка
' fs.GetFolder("..") - корневая папка
' Проверки для c:
' fs.FolderExists("c:\") = True - есть на диске
' fs.GetFolder("c:\").IsRootFolder = True - корневая папка
'
Private Sub butViewSpecFolder_Click()
On Error GoTo 999
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Me.progress = _
"Папка Windows: " fs.GetSpecialFolder(0) vbCrLf _
"Папка System: " fs.GetSpecialFolder(1) vbCrLf _
"Папка Temp: " fs.GetSpecialFolder(2) vbCrLf _
"Текущая папка: " fs.GetFolder(Me.myFolder "\.") vbCrLf _
"Родительская папка: " fs.GetFolder(Me.myFolder "\..") vbCrLf _
""
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
' Получить список файлов
' fs.GetFolder(".").Files
'
Private Sub butViewFiles_Click()
On Error GoTo 999
Dim fs, fc, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Set fc = fs.GetFolder(Me.myFolder).Files
Me.progress = "Count=" fc.Count vbCrLf
For Each f1 In fc
Me.progress = Me.progress f1.Name vbCrLf
Next
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
' Получить список подчиненных папок
' fs.GetFolder(".").SubFolders
'
Private Sub butViewSubFolders_Click()
On Error GoTo 999
Dim fs, fc, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Set fc = fs.GetFolder(Me.myFolder).SubFolders
Me.progress = "Count=" fc.Count vbCrLf
For Each f1 In fc
Me.progress = Me.progress f1.Name vbCrLf
Next
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
' Прочитать все свойства папки
' f1.DateCreate - дата создания папки
'
Private Sub butDrive_Click()
On Error GoTo 999
Dim fs, f1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f1 = fs.GetFolder(Me.myFolder).drive
Me.progress = _
"DriveLetter: " f1.DriveLetter vbCrLf _
"AvailableSpace: " f1.AvailableSpace vbCrLf _
"DriveType: " f1.DriveType vbCrLf _
"FileSystem: " f1.FileSystem vbCrLf _
"FreeSpace: " f1.FreeSpace vbCrLf _
"IsReady: " f1.IsReady vbCrLf _
"Path: " f1.Path vbCrLf _
"SerialNumber: " f1.SerialNumber vbCrLf _
"ShareName: " f1.ShareName vbCrLf _
"TotalSize: " f1.TotalSize vbCrLf _
"VolumeName: " f1.VolumeName
Exit Sub 'Выходим из программы
999:
MsgBox Err.Description
Err.Clear 'Очищаем поток от ошибок
End Sub
'==============================================================
Private Sub Form_Open(Cancel As Integer)
' Устанавливаем каталог
ChDir Application.CurrentProject.Path
' Определение имени новой папки
Me.myFolder = Application.CurrentProject.Path
End Sub
15. Некоторые виды интерфейса требуют, чтобы в полях показывался результат выполнения нескольких полей. Например, итоговая сумма по заказу. Это делается следующим способом.
Private Sub Form_Open(Cancel As Integer)
Me.Итого.ControlSource = "=[Сумма]*[Наценка]"
End Sub
При разработке интерфейса Вам может потребоваться погасить или отобразить некоторые кнопки меню. Этот пример показывает, как можно это сделать.
'==============================================================
' Вставить кнопку
Private Sub butInsert_Click()
Dim But As CommandBarButton 'Mso9.dll
On Error GoTo 999
Set But = Application.CommandBars("Мое меню").Controls.Add(msoControlButton)
With But
.BeginGroup = True 'Начинаем размещение с начала группы
.FaceId = 1 'Устанавливаем код кнопки
.Style = msoButtonCaption 'Выбираем стандартный тип
.Caption = "Привет" 'Называем кнопку
.TooltipText = "Мой привет всем!" 'Всплывающая подсказка
.OnAction = "=msgbox(""Привет всем!"")" 'Моя программа
End With
Exit Sub
999:
Err.Clear
End Sub
'==============================================================
' Удалить кнопку
Private Sub butDelete_Click()
On Error GoTo 999
Application.CommandBars("Мое меню").Controls("Привет").Delete
999:
Err.Clear
End Sub
Данный пример определяет коды клавиш меню для быстрого запуска команд. Например, чтобы вызвать пункт меню "Сервис\Схема данных" достаточно запустить команду: 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
06. Этот метод показывает Вам как отобразить рисунок в форме, но не хранить его в таблице базы.
'==============================================================
' Изменение рисунка
Private Sub Form_Current()
Dim s As String
On Error GoTo 999
s = Application.CodeProject.Path 'Каталог программы
myPicture.Picture = s "\" Me.Рисунок 'Вставляем новый рисунок
Me.Рисунок.Visible = False 'Гасим рисунок
Exit Sub
999:
Err.Clear
Me.Рисунок.Visible = True 'Показываем поле
myPicture.Picture = "" 'Нет рисунка
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
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
Если Вам необходимо сформировать динамический (быстрый) просмотр данных, то имеет смыл у отчета вообще не указывать запрос. А при открытии его вызвать например форму и изменить его отображение. В примере, показано как установить фильтр для источник записи (08 Отчеты\la_report1.accdb. 20. Изменение запроса отчета).
Private Sub Report_Open(Cancel As Integer)
Me.RecordSource = "SELECT * From Cправочник WHERE [Цена]50"
End Sub
У Microsoft Office есть специальный диалог открытия файлов, который имеет много интересных свойств. Он лучше диалога Windows. В этом примере показано как можно его использовать.
Private Sub butSelectFile_Click()
' Включите библитеку libDialogFiles
Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub
'#Const constOffice2000 = 0 ' Для Microsoft Office 97
#Const constOffice2000 = 1 ' Для Microsoft Office 2000
Private Declare Function funOfficeGetFile _
Lib "msaccess.exe" Alias "#56" _
(gfni As accOfficeGetFileNameInfo, fOpen As Integer) As Long
' OfficeGetFileName flags
Public Const flagNoChangeDir = H2 ' Не меняет каталог пользователя
Public Const flagDirectoryOnly = H20 ' Открывает только папку
Public Type accOfficeGetFileNameInfo
hwndOwner As Long
strAppName As String * 255
strDlgTitle As String * 255
strOpenTitle As String * 255
strFile As String * 4096
strInitialDir As String * 255
strFilter As String * 255
lngFilterIndex As Long
lngView As Long
lngFlags As Long
End Type
'Функция открытия файла
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
FILENAME As OPENFILENAME) As Boolean
'Функция сохранения файла
Declare Function apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
FILENAME As OPENFILENAME) As Boolean
'Структура файла, описание дано ниже
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
'Флажки для параметра OPENFILENAME.Flags
' (например, OFN_FILEMUSTEXIST Or OFN_READONLY)
Const OFN_READONLY = H1
Const OFN_OVERWRITEPROMPT = H2
Const OFN_HIDEREADONLY = H4
Const OFN_NOCHANGEDIR = H8
Const OFN_SHOWHELP = H10
Const OFN_ENABLEHOOK = H20
Const OFN_ENABLETEMPLATE = H40
Const OFN_ENABLETEMPLATEHANDLE = H80
Const OFN_NOVALIDATE = H100
Const OFN_ALLOWMULTISELECT = H200
Const OFN_EXTENSIONDIFFERENT = H400
Const OFN_PATHMUSTEXIST = H800
Const OFN_FILEMUSTEXIST = H1000
Const OFN_CREATEPROMPT = H2000
Const OFN_SHAREAWARE = H4000
Const OFN_NOREADONLYRETURN = H8000
Const OFN_NOTESTFILECREATE = H10000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
' Получение папки для программы
Public Function fOfficeGetFileName( _
gfni As accOfficeGetFileNameInfo, _
ByVal fOpen As Integer) As Long
Dim lngReturn As Long
With gfni
.strAppName = RTrim$(.strAppName) vbNullChar
.strDlgTitle = RTrim$(.strDlgTitle) vbNullChar
.strOpenTitle = RTrim$(.strOpenTitle) vbNullChar
.strFile = RTrim$(.strFile) vbNullChar
.strInitialDir = RTrim$(.strInitialDir) vbNullChar
.lngFilterIndex = 1
.strFilter = RTrim$(.strFilter) vbNullChar '"Все файлы (*.*)" vbNullChar
lngReturn = funOfficeGetFile(gfni, fOpen)
.strAppName = fTrimNull(.strAppName)
.strDlgTitle = fTrimNull(.strDlgTitle)
.strOpenTitle = fTrimNull(.strOpenTitle)
.strFile = fTrimNull(.strFile)
.strInitialDir = fTrimNull(.strInitialDir)
.strFilter = fTrimNull(.strFilter)
End With
fOfficeGetFileName = lngReturn
End Function
'Обрезка данных
Private Function fTrimNull(strVal As String) As String
Dim lngPos As Long
lngPos = InStr(1, strVal, vbNullChar)
Select Case lngPos
Case Is 1: fTrimNull = Left$(strVal, lngPos - 1)
Case 0: fTrimNull = strVal
Case 1: fTrimNull = vbNullString
End Select
End Function
'==============================================================
' Назначение
' Открытие окна диалога файлов
' Параметры:
' strFilter - строка фильтра
' strIniFile - файл инициализации
' strTitleDlg - заголовок окна
' strDefExt - расширение по умолчанию
' strCurDir - текущая папка
'
Public Function fGetSaveFileName( _
hwnd As Long, _
strFilter As String, _
strIniFile As String, _
strTitleDlg As String, _
strDefExt As String, _
strCurDir As String) As String
Dim OFNAME As OPENFILENAME 'Назначаем переменную для файла
Dim flag As Boolean
'Заполним структуру перед вызовом GetOpenFileName
With OFNAME
.lStructSize = Len(OFNAME) 'Размер структуры в байтах
.hwndOwner = hwnd 'Указатель окна
.lpstrFilter = strFilter 'Фильтр отбора
.nFilterIndex = 1 'Индекс первой пары строк фильтра
.lpstrFile = strIniFile String$(512 - Len(strIniFile), 0) 'Полное имя файла
.nMaxFile = 511 'Размер буфера файла
.lpstrFileTitle = String$(512, 0) 'Только имя файла окна
.nMaxFileTitle = 511 'Размер буфера заголовка
.lpstrTitle = strTitleDlg 'Заголовок окна диалога
.flags = OFN_FILEMUSTEXIST 'Типы читаемых файлов
.lpstrDefExt = strDefExt 'Расширение файла по умолчанию
.lpstrInitialDir = strCurDir 'Каталог файлов по умолчанию
.hInstance = 0 'Идентификатор блока данных для OFN_ENABLETEMPLATE
.lpstrCustomFilter = 0 'Дополнительные фильтры, см. ниже
.nMaxCustFilter = 0 'не менее 40, 0 - игнорируется
.nFileOffset = 0 'Определяет смещение имени
.nFileExtension = 0 'Определяет расширение
.lCustData = 0 'Для собственных окон
.lpfnHook = 0 'Указатель на функцию фильтра
.lpTemplateName = 0 'Собственный диалог
'*** Старт
flag = apiGetSaveFileName(OFNAME) 'Общий случай
If flag Then 'Открываем диалог и находим имя файла
fGetSaveFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
Else
fGetSaveFileName = ""
End If
End With
End Function
'==============================================================
' Выполнение действий
Public Function fOfficeGetFile(strTitle As String, strInitDir As String, strFilter As String, Optional officeFlags As Long) As String
Dim lngFlags As Long
Dim gfni As accOfficeGetFileNameInfo
On Error GoTo 999
With gfni
If officeFlags 0 Then .lngFlags = officeFlags
.strFilter = strFilter
.strFile = ""
.strDlgTitle = "Выберите файл"
.strOpenTitle = ""
.strInitialDir = strInitDir
.hwndOwner = Application.hWndAccessApp
End With
If fOfficeGetFileName(gfni, -1) = 0 Then
fOfficeGetFile = Trim(gfni.strFile)
Else
fOfficeGetFile = ""
End If
Exit Function
999:
MsgBox Err.Description
Err.Clear
End Function