Лабораторный практикум в Access / Лабораторный практикум в Access / Примеры программ на VBA
.docПримеры выполнения ряда действий, связанных с написанием программ на Visual Basic for Application в Access.
Большое количество примеров решения задач, связанных с разработкой интерфейса БД, с их развернутым описанием имеется в специализированной БД Solutions, поставляемой с установкой MS Office 97 Eng. К сожалению, в более поздние версии MS Office данная БД включена не была.
В данном руководстве приведены примеры программ обработки событий формы Книги БД «Публикации». Следовательно, вы должны изменить название таблиц, полей и элементов управления в примерах соответственно вашей схеме БД.
Отображение панели инструментов совместно с загрузкой формы
Private Sub Form_Activate()
' Hide Form View toolbar.
DoCmd.ShowToolbar "Form View", acToolbarNo
' Use AllowEdits property setting to determine which toolbar to show.
' If Me.AllowEdits = True Then
' DoCmd.ShowToolbar "EnterOrEditProducts2", acToolbarYes
' Else
DoCmd.ShowToolbar "SearchArticlesToolbar", acToolbarYes
' End If
End Sub
Private Sub Form_Deactivate()
' Hide Custom toolbar.
DoCmd.ShowToolbar "SearchArticlesToolbar", acToolbarNo
' Show Form View toolbar.
DoCmd.ShowToolbar "Form View", acToolbarWhereApprop
End Sub
Фильтрация записей в форме (ArticleID_edit, Name_edit – это поля для ввода условия поиска, размещенные на форме)
Private Sub ApplyFilter_Click()
Me.Filter = "[ArticleID] = Me![ArticleID_edit]"
' or
' Me.Filter = "[Name] = '"Me![Name_edit] & "'"
Me.FilterOn = True
End Sub
Private Sub RemoveFilter_Click()
' Me.Filter = ""
Me.FilterOn = False
End Sub
Поиск записи в форме с помощью поля со списком, размещенного в заголовке формы
Private Sub ПолеСоСписком1_AfterUpdate()
Dim rs As Object
Set rs = Me.Recordset.Clone
rs.FindFirst "[TopicID] = " & Str(Me![ ПолеСоСписком1])
Me.Bookmark = rs.Bookmark
End Sub
Подавление вывода или смена сообщения об удалении записей
Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)
' Allows user to delete record(s).
Dim intDelRecord As Integer, strTitle As String
Dim intMsgDialog As Integer, strMsg As String
' Display message box asking if the user wants to to delete record(s).
strTitle = "Delete record(s)"
strMsg = "You are about to delete the record(s)?"
intMsgDialog = vbYesNo + vbExclamation
intDelRecord = MsgBox(strMsg, intMsgDialog, strTitle)
If intDelRecord = vbYes Then
Response = acDataErrContinue
Else
Cancel = True
End If
End Sub
Автоматический переход к полю при открытии формы и переходам по записям
Private Sub Form_Current()
If IsNull(Me![ArticleID]) Then
DoCmd.GoToControl "Title"
End If
End Sub
Вывод подсказки к первичному заполнению полей базовой таблицы при работе в составной форме (если перейти к новой записи в составной форме и сразу же приступить к заполнению полей в подчиненной форме, будет выдано сообщение об ошибке)
Private Sub KeywordsSubform_Enter()
If IsNull([ArticleID]) Then
MsgBox "Enter article information before entering keywords information."
DoCmd.GoToControl "Title"
End If
End Sub
Private Sub Articles_Subform_Enter()
If IsNull([ArticleID]) Then
MsgBox "Enter article information before entering author information."
DoCmd.GoToControl "Title"
End If
End Sub
Автоматизированный ввод подтемы для книги по двойному нажатию кнопки мыши на элементе управления (SubTopicID – это элемент управления поле со списком)
Private Sub SubTopicID_DblClick(Cancel As Integer)
On Error GoTo Err_SubTopicID_DblClick
Dim lngTopicID As Long
If IsNull(Me![SubTopicID]) Then
Me![SubTopicID].text = ""
Else
lngTopicID = Me![SubTopicID]
Me![SubTopicID] = Null
End If
DoCmd.OpenForm "SubTopics", acNormal, , , , acDialog, "GotoNew"
Me![SubTopicID].Requery
If lngTopicID <> 0 Then Me![SubTopicID] = lngTopicID
Exit_SubTopicID_DblClick:
Exit Sub
Err_SubTopicID_DblClick:
MsgBox Err.Description
Resume Exit_SubTopicID_DblClick
End Sub
Ввод новой темы для книги по нажатию кнопки, например, размещенной справа от выпадающего списка тем (TopicID – это элемент управления поле со списком)
Private Sub ButtonAddNewTopic_Click()
On Error GoTo Err_ ButtonAddNewTopic _Click
Dim stDocName As String
stDocName = "Topics"
DoCmd.OpenForm stDocName, , , , acFormAdd, acDialog
Me!TopicID.Requery
Exit_ButtonAddNew_Click:
Exit Sub
Err_ButtonAddNew_Click:
MsgBox Err.Description
Resume Exit_ButtonAddNew_Click
End Sub
Те же действия, что и в предыдущем примере, но в более автоматизированном виде. Реализован путем обработки события отсутствие в списке, т.е. предпринимается попытка ввести новую тему напрямую в поле со списком (TopicID – это элемент управления поле со списком)
Private Sub TopicID_NotInList(NewData As String, Response As Integer)
' Allows user to add a new topic.
Dim intNewTopic As Integer, strTitle As String
Dim intMsgDialog As Integer, strMsg As String
' Display message box asking if the user wants to add a new topic.
strTitle = "Topic not in List"
strMsg = "Do you want to add a new topic or modify this?"
intMsgDialog = vbYesNo + vbExclamation
intNewTopic = MsgBox(strMsg, intMsgDialog, strTitle)
If intNewTopic = vbYes Then
DoCmd.OpenForm "Topics", acNormal, , , , acDialog, "GotoNew"
Me![TopicID] = Null
Me![TopicID].Requery
' Continue without displaying default error message.
Response = acDataErrAdded
If GlobalData <> 0 And Not IsNull(GlobalData) Then Me![TopicID] = GlobalData
If IsNull(Me![TopicID]) Then
Me![TopicID].text = ""
End If
Else
Response = acDataErrContinue
TopicID.Undo
End If
End Sub
В форме ввода новой темы, вызываемой из предыдущей процедуры, необходима обработка следующих событий
Private Sub Form_Load()
Dim newText As String
If Me.OpenArgs = "GotoNew" And Not IsNull(Me![TopicID]) Then
DoCmd.DoMenuItem acFormBar, 3, 0, , acMenuVer70
If IsLoaded("Articles") Then
newText = Forms![Articles]![TopicID].text
If newText <> "" Then Me![Topic] = newText
End If
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
GlobalData = Me![TopicID]
End Sub
В этом примере также необходимо наличие объявления
Global GlobalData As Variant
в области объявлений стандартного модуля. В стандартном модуле также полезно разместить следующие функции:
Function IsLoaded(ByVal strFormName As String) As Boolean
' Returns True if the specified form is open in Form view or Datasheet view.
Const conObjStateClosed = 0
Const conDesignView = 0
If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
If Forms(strFormName).CurrentView <> conDesignView Then
IsLoaded = True
End If
End If
End Function
Function LockedControls(frm As Form, intSection As Integer, intState As Boolean) As Boolean
' Enable or disable controls in specified section of form.
' Use the Form object, section constant and state arguments passed to the EnableControls procedure.
Dim ctl As Control
' Set intState for all controls in specified section.
For Each ctl In frm.Controls
If ctl.Section = intSection Then
On Error Resume Next
ctl.Locked = intState
Err = 0
End If
Next ctl
LockedControls = True
End Function
Автоматизированный ввод ключевого слова поиска для книги, реализованный путем прямого ввода нового ключевого слова в поле ввода комбинированного списка, т.е. без вызова формы ввода ключевых слов (допустимо в случае, если заданию подлежит только одно поле в форме; KeywordID – это элемент управления поле со списком)
Private Sub KeywordID_NotInList(NewData As String, Response As Integer)
Dim intNewKeyword As Integer, strTitle As String
Dim intMsgDialog As Integer, strMsg As String
Dim rst As Recordset
Dim data As Long
' Display message box asking if the user wants to add a new keyword
strTitle = "Keyword not in List"
strMsg = "Do you want to add a new keyword?"
intMsgDialog = vbYesNo + vbExclamation
intNewKeyword = MsgBox(strMsg, intMsgDialog, strTitle)
If intNewKeyword = vbYes And NewData <> "" Then
Set rst = CurrentDb.OpenRecordset("Keywords", dbOpenDynaset)
rst.AddNew
rst![Keyword] = NewData
rst.Update
rst.MoveLast
data = rst![KeywordID]
rst.Close
Me![KeywordID] = Null
Me![KeywordID].Requery
' Continue without displaying default error message.
Response = acDataErrAdded
If Not IsNull(data) Then
Me![KeywordID] = data
Else
Me![KeywordID].text = ""
End If
Else
Response = acDataErrContinue
Me![KeywordID].Undo
End If
End Sub
Поиск книги с помощью дополнительной формы
Private Sub Find_Click()
Dim strWHERE As String
Dim strCollection(1 To 8) As String
Dim i As Integer
If Me![MatchGroup] = 1 Then
If Not IsNull(Me![SearchByTitle]) Then
strCollection(1) = "Articles.Title = Forms![AdvancedFilter]![SearchByTitle]"
End If
If Not IsNull(Me![SearchByAuthor]) Then
strCollection(2) = "Articles.ArticleID IN (SELECT ArticlesAuthors.ArticleID FROM ArticlesAuthors WHERE ArticlesAuthors.AuthorID = Forms![AdvancedFilter]![SearchByAuthor])"
End If
If Not IsNull(Me![SearchByTopic]) Then
strCollection(3) = "Topics.Topic = Forms![AdvancedFilter]![SearchByTopic]"
End If
If Not IsNull(Me![SearchBySubTopic]) Then
strCollection(4) = "SubTopics.SubTopic = Forms![AdvancedFilter]![SearchBySubTopic]"
End If
If Not IsNull(Me![SearchByKeyword]) Then
strCollection(5) = "Articles.ArticleID IN (SELECT ArticleKeywords.ArticleID FROM Keywords INNER JOIN ArticleKeywords ON Keywords.KeywordID = ArticleKeywords.KeywordID WHERE Keywords.Keyword = Forms![AdvancedFilter]![SearchByKeyword])"
End If
If Not IsNull(Me![SearchByPublishedYear]) Then
strCollection(6) = "Year(Articles.PublishedDate) = Forms![AdvancedFilter]![SearchByPublishedYear]"
End If
If Not IsNull(Me![SearchByFolder]) Then
strCollection(8) = "Articles.Folder = Forms![AdvancedFilter]![SearchByFolder]"
End If
ElseIf Me![MatchGroup] = 2 Then
If Not IsNull(Me![SearchByTitle]) Then
strCollection(1) = "Articles.Title Like " & """*" & Forms![AdvancedFilter]![SearchByTitle] & "*" & """ "
End If
If Not IsNull(Me![SearchByAuthor]) Then
strCollection(2) = "Articles.ArticleID IN (SELECT ArticlesAuthors.ArticleID FROM Authors INNER JOIN ArticlesAuthors ON Authors.AuthorID = ArticlesAuthors.AuthorID WHERE Authors.FirstName Like " & """*" & Forms![AdvancedFilter]![SearchByAuthor] & "*" & """ Or Authors.LastName Like " & """*" & Forms![AdvancedFilter]![SearchByAuthor] & "*" & """) "
End If
If Not IsNull(Me![SearchByTopic]) Then
strCollection(3) = "Topics.Topic Like " & """*" & Forms![AdvancedFilter]![SearchByTopic] & "*" & """ "
End If
If Not IsNull(Me![SearchBySubTopic]) Then
strCollection(4) = "SubTopics.SubTopic Like " & """*" & Forms![AdvancedFilter]![SearchBySubTopic] & "*" & """ "
End If
If Not IsNull(Me![SearchByKeyword]) Then
strCollection(5) = "Articles.ArticleID IN (SELECT ArticleKeywords.ArticleID FROM Keywords INNER JOIN ArticleKeywords ON Keywords.KeywordID = ArticleKeywords.KeywordID WHERE Keywords.Keyword Like " & """*" & Forms![AdvancedFilter]![SearchByKeyword] & "*" & """)"
End If
If Not IsNull(Me![SearchByPublishedYear]) Then
strCollection(6) = "Year(Articles.PublishedDate) Like " & """*" & Forms![AdvancedFilter]![SearchByPublishedYear] & "*" & """ "
End If
If Not IsNull(Me![SearchByFolder]) Then
strCollection(8) = "Articles.Folder Like " & """*" & Forms![AdvancedFilter]![SearchByFolder] & "*" & """ "
End If
End If
If Not IsNull(Me![SearchByBookcase]) Then
strCollection(7) = "Articles.Bookcase = Forms![AdvancedFilter]![SearchByBookcase]"
End If
For i = 1 To 8
If Not IsNull(strCollection(i)) And strCollection(i) <> "" Then
If Not IsNull(strWHERE) And strWHERE <> "" Then
strWHERE = strWHERE & " AND "
End If
strWHERE = strWHERE & strCollection(i)
End If
Next
If Not IsNull(strWHERE) And strWHERE <> "" Then
Forms![SearchArticles].RecordSource = "SELECT DISTINCTROW Articles.* FROM Topics RIGHT JOIN (SubTopics RIGHT JOIN Articles ON SubTopics.SubTopicID = Articles.SubTopicID) ON Topics.TopicID = Articles.TopicID" & " WHERE " & strWHERE & " ORDER BY Articles.Title;"
Me.Visible = False
Forms![SearchArticles].SetFocus
DoCmd.Restore
End If
End Sub
Private Sub Form_Open(Cancel As Integer)
If Not IsLoaded("SearchArticles") Then Cancel = True
End Sub
Private Sub MatchGroup_AfterUpdate()
If Me![MatchGroup] = 1 Then
Me![SearchByTitle].LimitToList = True
Me![SearchByAuthor].BoundColumn = 1
Me![SearchByAuthor].LimitToList = True
Me![SearchByTopic].LimitToList = True
Me![SearchBySubTopic].LimitToList = True
Me![SearchByKeyword].LimitToList = True
Me![SearchByPublishedYear].InputMask = "9999"
Me![SearchByBookcase].LimitToList = True
Me![SearchByFolder].LimitToList = True
ElseIf Me![MatchGroup] = 2 Then
Me![SearchByTitle].LimitToList = False
With Me![SearchByAuthor]
.BoundColumn = 2
.LimitToList = False
End With
Me![SearchByTopic].LimitToList = False
Me![SearchBySubTopic].LimitToList = False
Me![SearchByKeyword].LimitToList = False
Me![SearchByPublishedYear].InputMask = ""
Me![SearchByBookcase].LimitToList = False
Me![SearchByFolder].LimitToList = False
End If
End Sub