Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset("Элементы кнопочной формы", dbOpenDynaset)
rst.FindFirst "[SwitchboardID]=" & Me![SwitchboardID] & " AND [ItemNumber]=" & intBtn
' Если нужная запись не найдена, вывод
' сообщения об ошибке и выход из функции.
If (rst.NoMatch) Then
MsgBox "Ошибка при чтении таблицы элементов кнопочной формы."
rst.Close
dbs.Close
Exit Function
End If
Select Case rst![Command]
' Переход к другой кнопочной форме.
Case conCmdGotoSwitchboard
Me.Filter = "[ItemNumber] = 0 AND [SwitchboardID]=" & rst![Argument]
' Открытие формы в режиме добавления записей.
Case conCmdOpenFormAdd
DoCmd.OpenForm rst![Argument], , , , acAdd
Открытиеформы.
Case conCmdOpenFormBrowse
DoCmd.OpenForm rst![Argument]
' Открытиеотчета.
Case conCmdOpenReport
DoCmd.OpenReport rst![Argument], acPreview
' Настройкакнопочнойформы.
Case conCmdCustomizeSwitchboard
' Обработка ситуации, когда диспетчер
' кнопочных форм не установлен
' (например, при сокращенной установке).
On Error Resume Next
Application.Run "WZMAIN80.sbm_Entry"
If (Err <> 0) Then MsgBox "Команда недоступна."
On Error GoTo 0
' Обновлениеформы.
Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'поумолчанию' "
Me.Caption = Nz(Me![ItemText], "")
FillOptions
' Выход из приложения.
Case conCmdExitApplication
CloseCurrentDatabase
' Запускмакроса.
Case conCmdRunMacro
DoCmd.RunMacro rst![Argument]
' Выполнениепрограммы.
Case conCmdRunCode
Application.Run rst![Argument]
' Другие команды не поддерживаются.
Case Else
MsgBox "Неизвестная команда."
End Select
' Закрытие набора записей и базы данных.
rst.Close
dbs.Close
HandleButtonClick_Exit:
ExitFunction
HandleButtonClick_Err:
' Если выполнение прервано пользователем,
' сообщение об ошибке не выводится. Вместо этого
' выполнение продолжается со следующей строки.
If (Err = conErrDoCmdCancelled) Then
Resume Next
Else
MsgBox "Ошибка при выполнении команды.", vbCritical
Resume HandleButtonClick_Exit
End If
End Function
Листинг программы для формы “Издание”
Option Compare Database
Dim FlCorr As Boolean
Option Explicit
'Открытие окна диалога Поиска.
Private Sub Find_Record_Click()
On Error GoTo Err_Find_Record_Click
Screen.PreviousControl.SetFocus
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_Find_Record_Click:
Exit Sub
Err_Find_Record_Click:
MsgBox Err.Description
Resume Exit_Find_Record_Click
End Sub
Private Sub Form_Load()
'Загрузкаформы
DoCmd.Maximize
FlCorr = True
продолжение приложения 2
End Sub
Private Sub Кнопка86_Click()
On Error GoTo Err_Кнопка86_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Аннотация"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Кнопка86_Click:
Exit Sub
Err_Кнопка86_Click:
MsgBox Err.Description
Resume Exit_Кнопка86_Click
End Sub
Private Sub Цена_Click()
On Error GoTo Err_Цена_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Цена"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Цена_Click:
Exit Sub
Err_Цена_Click:
MsgBox Err.Description
Resume Exit_Цена_Click
End Sub
'Просмотр библиографического описания по ГОСТ
Private Sub ГОСТ_Click()
On Error GoTo Err_ГОСТ_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Описание по ГОСТ"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_ГОСТ_Click:
Exit Sub
Err_ГОСТ_Click:
MsgBox Err.Description
Resume Exit_ГОСТ_Click
End Sub
'Вызов формы поиска по фильтру
Private Sub Фильтр_Click()
On Error GoTo Err_Фильтр_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Фильтр"
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Фильтр_Click:
Exit Sub
Err_Фильтр_Click:
MsgBox Err.Description
Resume Exit_Фильтр_Click
End Sub
Private Sub Тематическая_справка_Click()
On Error GoTo Err_Тематическая_справка_Click
'Просмотр отчета для отобранных значений в форме "Издение"
Dim stDocName As String
Dim strFilter As String
stDocName = "Тематическаясправка"
strFilter = Me.Filter
DoCmd.OpenReport stDocName, acPreview, , strFilter
Exit_Тематическая_справка_Click:
Exit Sub
Err_Тематическая_справка_Click:
MsgBox Err.Description
Resume Exit_Тематическая_справка_Click
End Sub
Private Sub Кнопка187_Click()
On Error GoTo Err_Кнопка187_Click
'Печать каталожной карточки
DimstrFilterAsString
Dim stDocName As String
stDocName = "Каталожнаякарточка"
strFilter = Me.Filter
DoCmd.OpenReport stDocName, acViewNormal, strFilter
Exit_Кнопка187_Click:
Exit Sub
Err_Кнопка187_Click:
MsgBox Err.Description
Resume Exit_Кнопка187_Click
End Sub
Листинг программы для формы “Библиографическое описание издание”
Option Compare Database
Dim FlCorr As Boolean
Option Explicit
Private Sub Find_Record_Click()
'ОткрытьформудиалогаПоиска.
On Error GoTo Err_Find_Record_Click
Screen.PreviousControl.SetFocus
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_Find_Record_Click:
Exit Sub
Err_Find_Record_Click:
MsgBox Err.Description
Resume Exit_Find_Record_Click
End Sub
Private Sub Form_Load()
FlCorr = True
DoCmd.Maximize
End Sub
Private Sub Form_Error(DataErr As Integer, Response As Integer)
'Перехват дубликата значения
Dim strMsg As String
Const conDupKey = 3022
If DataErr = conDupKey Then
strMsg = "Вы ввели дубликат идентификатора книги"
strMsg = strMsg & "Пожалуйста введите новое значение"
MsgBox strMsg
[Идентификатор издания].SetFocus
Response = acDataErrContinue
End If
End Sub
Private Sub Form_AfterUpdate()
' Обновляет поле со списком "Языковой материал" после изменения записи.
Me!ТипИздания.Requery
End Sub
Private Sub INVNum_Click()
On Error GoTo Err_INVNum_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Добавление инвентарных записей"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_INVNum_Click:
Exit Sub
Err_INVNum_Click:
MsgBox Err.Description
Resume Exit_INVNum_Click
End Sub
Private Sub ТипИздания_NotInList(NewData As String, Response As Integer)
'Добавление пользователем нового элемента в список
Dim ctl As Control
'Определяет поле со списком в качестве объекта элемента управления
Set ctl = Me!ТипИздания
'Подтверждение на ввод нового значения
If MsgBox("Собираетесь добавить новое значение в список?", vbOKCancel) _
Then
'Установить аргумент Response для отображения добавляемого значения
Response = acDataErrAdded
'Добавляет строку в список значений в источник строки
Debug.Print ctl.RowSource
ctl.RowSource = ctl.RowSource & ";" & NewData
Debug.Print ctl.RowSource
Else
'Если нажата кнопка отмена - выдается сообщение об ошибке
Response = acDataErrContinue
ctl.Undo
End If
End Sub
'Private Sub Form_AfterUpdate()
' Обновляет поле со списком "Языковой материал" после изменения записи.
' Me!ТипИздания.Requery
'End Sub
Private Sub Кнопка84_Click()
On Error GoTo Err_Кнопка84_Click
DoCmd.GoToRecord , , acNewRec
FlCorr = False
Exit_Кнопка84_Click:
Exit Sub
Err_Кнопка84_Click:
MsgBox Err.Description
Resume Exit_Кнопка84_Click
End Sub
Private Sub Кнопка86_Click()
On Error GoTo Err_Кнопка86_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Аннотация"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Кнопка86_Click:
Exit Sub
Err_Кнопка86_Click:
MsgBox Err.Description
Resume Exit_Кнопка86_Click
End Sub
Private Sub Цена_Click()
продолжение приложения 2
On Error GoTo Err_Цена_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Цена"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Цена_Click:
Exit Sub
Err_Цена_Click:
MsgBox Err.Description
Resume Exit_Цена_Click
End Sub
Private Sub ГОСТ_Click()
On Error GoTo Err_ГОСТ_Click
Dim stDocName As String
Dim stLinkCriteria As String
stDocName = "Описание по ГОСТ"
stLinkCriteria = "[Идентификатор издания]=" & Me![Идентификатор издания]
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_ГОСТ_Click:
Exit Sub
Err_ГОСТ_Click:
MsgBox Err.Description
Resume Exit_ГОСТ_Click
EndSub
продолжение приложения 2
Private Sub Удаление_Click()
On Error GoTo Err_Удаление_Click
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
Exit_Удаление_Click:
Exit Sub
Err_Удаление_Click:
MsgBox Err.Description
Resume Exit_Удаление_Click
EndSub
Листинг программы формы “Просмотр книг”
Option Compare Database
Option Explicit
Private Sub cmdSome_Click()
Dim strWhere As String, varItem As Variant
Dim gstrWhereBook As String
If Me!lstBName.ItemsSelected.Count = 0 Then
'ExitSub
End If
For Each varItem In Me!lstBName.ItemsSelected
strWhere = strWhere & _
Me!lstBName.Column(0, varItem) & ","
Next varItem
' Удаление лишней запятой в строке IN
strWhere = Left$(strWhere, Len(strWhere) - 1)
' Открытие формы для просмотра всех данных о книге с отбором
продолжение приложения 2
'выделенных книг
gstrWhereBook = "[Идентификатор издания] IN (" & _
strWhere & ")"
DoCmd.OpenForm "Издание", WhereCondition:=gstrWhereBook
End Sub
Private Sub Form_Load()
DoCmd.Maximize
End Sub
Private Sub lstBName_DblClick(Cancel As Integer)
Dim strWhere As String, varItem As Variant
Dim gstrWhereBook As String
If Me!lstBName.ItemsSelected.Count = 0 Then
'ExitSub
End If
For Each varItem In Me!lstBName.ItemsSelected
strWhere = strWhere & _
Me!lstBName.Column(0, varItem) & ","
Next varItem
' Удаление лишней запятой в строке IN
strWhere = Left$(strWhere, Len(strWhere) - 1)
' Открытие формы для просмотра всех данных о книге с отбором
'выделенных книг
gstrWhereBook = "[Идентификатор издания] IN (" & _
strWhere & ")"
DoCmd.OpenForm "Издание", WhereCondition:=gstrWhereBook
End Sub
Листинг программы для формы “Краткие сведения о книгах”
Option Compare Database
Option Explicit
‘Реакциянанажатиекнопки “Подробнее”
Private Sub Detalis_Click()
Dim gstrWhereBook As String
' Открывает форму для книги, выбранной в списке
gstrWhereBook = "[Идентификатор издания] = " & _
Me![Идентификатор издания]
DoCmd.OpenFormFormName:="Описание по ГОСТ", _
WhereCondition:=gstrWhereBook
DoCmd.Close acForm, Me.Name
Forms![Описание по ГОСТ].SetFocus
EndSub
Листинг формы “Сведения в архив”
(форма вызывается для отправки в архив сведений о списанной литературе, вызывается двойным щелчком мыши на любой записи формы “Библиографическое описание”)
Option Compare Database
Option Explicit
Private Sub Post()
'Предлагаетархивироватьвыбранныезаписи
Dim wsp As Workspace, dbsCurrent As Database
Dim rstPost As Recordset
Dim intCount As Integer, blnInTrans As Boolean
Dim varReturn As Variant, strMsg As String
Dim strSQLArchive As String, strSQLDelete As String
Dim dtmCutOff As Double, intChoice As Integer
Dim dat As Date, dtmCutPr As String
Dim A As String
On Error GoTo Err_Post
dat = Date
blnInTrans = False
Set wsp = DBEngine.Workspaces(0)
Set dbsCurrent = CurrentDb()
' Подпрограммаархивации
ArchiveTrans:
intChoice = MsgBox("Будете добавлять в архив новые записи?", _
vbYesNo + vbQuestion, "Архивация?")
If intChoice = 7 Then
GoTo Exit_Post
Else
'Отключение предупреждения Access
DoCmd.SetWarnings False
dtmCutOff = Me![Инвентарныйномер]
If Not Me![Состояние] = "на руках" Then
strSQLArchive = "INSERT INTO [Списанная литература] ([Инвентарный номер], [Идентификатор издания], [Цена издания], [Дата списания], [Причина списания], [Название книги]) " & _