46695 (588433), страница 10
Текст из файла (страница 10)
Листинг программы главной кнопочной формы
Option Compare Database
Option Explicit
Private Sub Form_LostFocus()
DoCmd.Maximize
End Sub
Private Sub Form_Open(Cancel As Integer)
' Свертывание окна базы данных,
' инициализация формы.
' Переход на страницу кнопочной формы, отмеченную для использования по умолчанию.
Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'по умолчанию' "
Me.FilterOn = True
End Sub
Private Sub Form_Current()
' Обновление заголовка и заполнение
' списка команд.
Me.Caption = Nz(Me![ItemText], "")
FillOptions
End Sub
Private Sub FillOptions()
' Заполнение команд для страницы
' кнопочной формы.
' Число кнопок в форме.
Const conNumButtons = 8
Dim dbs As Database
Dim rst As Recordset
Dim strSQL As String
Dim intOption As Integer
' Установка фокуса на первую кнопку формы,
' скрытие всех кнопок формы, кроме первой.
' Поле с фокусом скрыть нельзя.
Me![Option1].SetFocus
For intOption = 2 To conNumButtons
Me("Option" & intOption).Visible = False
Me("OptionLabel" & intOption).Visible = False
Next intOption
' Открытие таблицы элементов кнопочной формы,
' поиск первого элемента текущей страницы формы.
Set dbs = CurrentDb()
strSQL = "SELECT * FROM [Элементы кнопочной формы]"
strSQL = strSQL & " WHERE [ItemNumber] > 0 AND [SwitchboardID]=" & Me![SwitchboardID]
strSQL = strSQL & " ORDER BY [ItemNumber];"
Set rst = dbs.OpenRecordset(strSQL)
' Вывод сообщения при отсутствии элементов
' на странице кнопочной формы. В остальных
' случаях - заполнение страницы элементами.
If (rst.EOF) Then
Me![OptionLabel1].Caption = "Элементы кнопочной формы отсутствуют"
Else
While (Not (rst.EOF))
Me("Option" & rst![ItemNumber]).Visible = True
Me("OptionLabel" & rst![ItemNumber]).Visible = True
Me("OptionLabel" & rst![ItemNumber]).Caption = rst![ItemText]
rst.MoveNext
Wend
End If
' Закрытие набора записей и базы данных.
rst.Close
dbs.Close
End Sub
Private Function HandleButtonClick(intBtn As Integer)
' Эта функция вызывается при нажатии кнопки.
' Аргумент intBtn указывает, какая кнопка была нажата.
' Константы для выполняемых команд.
Const conCmdGotoSwitchboard = 1
Const conCmdOpenFormAdd = 2
Const conCmdOpenFormBrowse = 3
Const conCmdOpenReport = 4
Const conCmdCustomizeSwitchboard = 5
Const conCmdExitApplication = 6
Const conCmdRunMacro = 7
Const conCmdRunCode = 8
' Особая ошибка.
Const conErrDoCmdCancelled = 2501
Dim dbs As Database
Dim rst As Recordset
On Error GoTo HandleButtonClick_Err
' Поиск записи, соответствующей нажатой кнопке,
' в таблице элементов кнопочной формы.
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:
Exit Function
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
'Печать каталожной карточки
Dim strFilter As String
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
![](https://s.studizba.com/z.php?f=/templates/si/i/noavatar.png&w=100&h=100&t=1"){kind=avatar}
