Реализация пользовательского приложения Модули форм

Главная

Option Compare Database

Private Sub Кнопка0_Click() ' открыть режим организации

On Error GoTo Err_Кнопка0_Click

Dim stDocName As String

Dim stLinkCriteria As String

stDocName = ChrW(1086) & ChrW(1088) & ChrW(1075) & ChrW(1072) & ChrW(1085) & ChrW(1080) & ChrW(1079) & ChrW(1072) & ChrW(1094) & ChrW(1080) & ChrW(1103)

DoCmd.OpenForm stDocName, , , stLinkCriteria

Exit_Кнопка0_Click:

Exit Sub

Err_Кнопка0_Click:

MsgBox Err.Description

Resume Exit_Кнопка0_Click

End Sub

Private Sub Кнопка1_Click() ' открыть режим проведения

On Error GoTo Err_Кнопка1_Click

Dim stDocName As String

Dim stLinkCriteria As String

stDocName = ChrW(1087) & ChrW(1088) & ChrW(1086) & ChrW(1074) & ChrW(1077) & ChrW(1076) & ChrW(1077) & ChrW(1085) & ChrW(1080) & ChrW(1077)

DoCmd.OpenForm stDocName, , , stLinkCriteria

Exit_Кнопка1_Click:

Exit Sub

Err_Кнопка1_Click:

MsgBox Err.Description

Resume Exit_Кнопка1_Click

End Sub

Private Sub Кнопка2_Click() ' открыть режим подведения итогов

On Error GoTo Err_Кнопка2_Click

Dim stDocName As String

Dim stLinkCriteria As String

stDocName = ChrW(1087) & ChrW(1086) & ChrW(1076) & ChrW(1074) & ChrW(1077) & ChrW(1076) & ChrW(1077) & ChrW(1085) & ChrW(1080) & ChrW(1077) & ChrW(32) & ChrW(1080) & ChrW(1090) & ChrW(1086) & ChrW(1075) & ChrW(1086) & ChrW(1074)

DoCmd.OpenForm stDocName, , , stLinkCriteria

Exit_Кнопка2_Click:

Exit Sub

Err_Кнопка2_Click:

MsgBox Err.Description

Resume Exit_Кнопка2_Click

End Sub

Private Sub Кнопка3_Click() ' выход

On Error GoTo Err_Кнопка3_Click

DoCmd.Quit

Exit_Кнопка3_Click:

Exit Sub

Err_Кнопка3_Click:

MsgBox Err.Description

Resume Exit_Кнопка3_Click

End Sub

Организация

Option Compare Database

Private Sub Form_Current() ' новая запись игры

If (Me![Поле9]) Then

nomerIgry = Me![Поле9]

Else

MsgBox "Введите сведенья об игре"

End If

End Sub

Private Sub Кнопка22_Click() ' проверка кол-ва участников

Dim myDb As Database

Dim myQ As QueryDef

Dim Rez As Recordset

Set myDb = CurrentDb

If (Me![Поле9]) Then

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ полка])As номер From [Участники-полки] where [№ игры ] =" & Me![Поле9] & " ;")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

'MsgBox (Rez![номер])

If Rez![Номер] > Me![Поле28] Then

MsgBox ("Превышение максимального количества участников!")

Else

MsgBox ("Возможно привлечь еще" & (Me![Поле28] - Rez![Номер]) & "полков")

End If

DoCmd.DeleteObject acQuery, "Counter"

Else

MsgBox ("отсутствуют данные об игре!")

End If

End Sub

Private Sub Кнопка30_Click() ' закрывает форму

On Error GoTo Err_Кнопка30_Click

DoCmd.Close

Exit_Кнопка30_Click:

Exit Sub

Err_Кнопка30_Click:

MsgBox Err.Description

Resume Exit_Кнопка30_Click

End Sub

Подчиненная форма

Private Sub №_полка_AfterUpdate()

Dim myDb As Database

Dim Res As Recordset

Dim myTab As TableDef

Dim f As Integer

Set myDb = CurrentDb

Set myTab = myDb.TableDefs("участники-Полки")

Set Res = myTab.OpenRecordset(dbOpenTable)

Do Until Res.EOF

If (Res![№ полка] = Me![№ полка] And Res![№ игры] = [Forms]!Организация![Поле9]) Then

MsgBox "Этот полк уже внесен в список!!!!! В следующем окне надо нажать ОК!! Измените или удалите введенный номер!!!"

End If

Res.MoveNext

Loop

'MsgBox [Forms]!Организация![Поле9]

Res.Close

Set myTab = myDb.TableDefs("Полки")

Set Res = myTab.OpenRecordset(dbOpenTable)

Do Until Res.EOF

If Res![№] = Me![№ полка] Then

GoTo m1

End If

Res.MoveNext

Loop

f = open_data(Me![№ полка])

m1:

End Sub

Проведение

Private Sub Кнопка22_Click() 'кнопка "проверить количество участников"

Dim myDb As Database

Dim myQ As QueryDef

Dim Rez As Recordset

Set myDb = CurrentDb

If (Me![Поле9]) Then

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ полка])As номер From [Участники-полки] where [№ игры ] =" & Me![Поле9] & " ;")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

'MsgBox (Rez![номер])

If Rez![Номер] > Me![Поле28] Then

MsgBox ("Превышение максимального количества участников!")

Else

MsgBox ("Возможно привлечь еще" & (Me![Поле28] - Rez![Номер]) & "полков")

End If

DoCmd.DeleteObject acQuery, "Counter"

Else

MsgBox ("отсутствуют данные об игре!")

End If

End Sub

Private Sub Кнопка32_Click() 'кнопка "ввести данные полка"

On Error GoTo Err_Кнопка32_Click

Dim myDb As Database

Dim myQ As QueryDef

Dim Table As TableDef

Dim Rez As Recordset

Dim Rez2 As Recordset

Dim answer As Integer

Dim mystr As Variant

Dim mystr2 As Variant

Set myDb = CurrentDb

mystr2 = """"

mystr = Me![Участники-полки]![№ полка]

m: Set myQ = myDb.CreateQueryDef("Polki", "SELECT Полки.№, Полки.Название, Полки.Разряд, Полки.База, Дивизии.Название, Полки.[Контактное лицо], Полки.Телефон FROM Дивизии INNER JOIN Полки ON Дивизии.№ = Полки.Дивизия where Полки.№ =" & mystr2 & mystr & mystr2 & " ;")

Set myQ = myDb.QueryDefs![Polki]

Set Rez = myQ.OpenRecordset()

If (Rez![№] = Me![Участники-полки]![№ полка]) Then

'DoCmd.OpenForm ("ввод данных")

DoCmd.OpenQuery "Polki"

Else

MsgBox ("нет данных")

End If

Exit_Кнопка32_Click:

Exit Sub

Err_Кнопка32_Click:

Select Case Err.Number

Case 3021 'нет такой записи в таблице

DoCmd.DeleteObject acQuery, "Polki"

answer = MsgBox("Вероятно, полк еще не участвовал в играх. Хотите создать новую запись полка?", vbYesNo + vbQuestion + vbDefaultButton1, "Неизвесиный полк")

If answer = vbYes Then

Set Rez2 = myDb.OpenRecordset("Полки", dbOpenDynaset)

Rez2.AddNew

Rez2![№] = Me![Участники-полки]![№ полка]

Rez2.Update

End If

Resume m

Case 3012 ' не потерли запрос полки

DoCmd.DeleteObject acQuery, "Polki"

Resume 0

Case Else

MsgBox "Error detected"

MsgBox (Str(Err.Number))

MsgBox (Err.Source)

MsgBox (Err.Description)

End Select

Resume Exit_Кнопка32_Click

End Sub

Private Sub Кнопка33_Click() ' кнопка Воисты

On Error GoTo Err_Кнопка33_Click

Dim myDb As Database

Dim myQ As QueryDef

Dim RezWithNumberOf As Recordset

Dim mystr As Variant

Dim mystr2 As Variant

nomerIgry = [Поле9]

mystr2 = """"

mystr = Me![Участники-полки]![№ полка]

Set myDb = CurrentDb

Set myQ = myDb.CreateQueryDef("Army", "SELECT Бойцы.*, [Участники-бойцы].Роль FROM Бойцы INNER JOIN [Участники-бойцы] ON Бойцы.№ = [Участники-бойцы].[№ бойца] WHERE [Полк]=" & mystr2 & mystr & mystr2 & " AND [№] in (SELECT [№ бойца] FROM [Участники-бойцы] WHERE [Участники-бойцы].[№ игры]=" & Me![Поле9] & ");") 'And Me![Участники-полки]![№ полка];")

stLinkCriteria = "№ =" & mystr2 & mystr & mystr2

DoCmd.OpenForm "Полки-состав", , , stLinkCriteria

MsgBox (myQ.SQL)

DoCmd.OpenQuery "Army"

Exit_Кнопка33_Click:

Exit Sub

Err_Кнопка33_Click:

MsgBox Err.Description

MsgBox (Str(Err.Number))

MsgBox (Err.Source)

Resume Exit_Кнопка33_Click

End Sub

Открывающаяся: Полки-состав

Private Sub Кнопка11_Click() 'кнопка закрыть форму

On Error GoTo Err_Кнопка11_Click

DoCmd.Close

DoCmd.DeleteObject acQuery, "Army"

Exit_Кнопка11_Click:

Exit Sub

Err_Кнопка11_Click:

MsgBox Err.Description

Resume Exit_Кнопка11_Click

End Sub

Подчиненная: Army

Private Sub Form_AfterUpdate()

Dim myDb As Database

Dim Res As Recordset

Dim myTab As TableDef

Dim answer As Integer

Dim temp As Variant

temp = -1

Set myDb = CurrentDb

' проверка по участникам

Set myTab = myDb.TableDefs("Участники-бойцы")

Set Res = myTab.OpenRecordset

Do Until Res.EOF ' для апдейта чисто роли

If (Res![№ бойца] = Me![№] And Res![№ игры] = nomerIgry) Then

Res.Edit

Res![Роль] = Me![Роль]

Res.Update

GoTo m1

End If

Res.MoveNext

Loop

Res.Close

Set myTab = myDb.TableDefs("бойцы")

Set Res = myTab.OpenRecordset

Do Until Res.EOF

If (Res![ФИО] = Me![ФИО] And Res![Год рождения] = Me![Год рождения] And Res![№] <> Me![№]) Then

answer = MsgBox("ВНИМАНИЕ! Совпадение Г.Р. и ФИО игроков! Объеденить в одну запись? (при этом кол-во раз участия++) ", vbYesNo + vbQuestion + vbDefaultButton1)

If answer = vbYes Then

temp = Res![раз участвовал] + 1

Res.Edit

Res![раз участвовал] = temp

Res.Update

temp = Res![№]

End If

End If

Res.MoveNext

Loop

Res.Close

Set myTab = myDb.TableDefs("Участники-бойцы")

Set Res = myTab.OpenRecordset

Res.AddNew ' новая запись

If temp = -1 Then

Res![№ бойца] = Me![№]

Else

Res![№ бойца] = temp

End If

Res![№ игры] = nomerIgry

Res![Роль] = Me![Роль]

Res.Update

Res.Close

Set myTab = myDb.TableDefs("бойцы")

Set Res = myTab.OpenRecordset

Do Until Res.EOF

If (Res![№] = Me![№]) Then

Res.Delete

End If

Res.MoveNext

Loop

Res.Close

m1:

End Sub

Подведение итогов

Private Sub Form_Current()

Dim myDb As Database

Dim myQ As QueryDef

Dim Rez As Recordset

Set myDb = CurrentDb

'MsgBox "start"

Dim mystr2 As Variant

mystr2 = """"

If (Me![Поле9]) Then

'просто все полки

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ полка])As номер From [Участники-полки] where [№ игры ] =" & Me![Поле9] & " ;")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

Me![Поле60] = Rez![Номер]

myQ.Close

DoCmd.DeleteObject acQuery, "Counter"

Rez.Close

'русские

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ полка])As номер From [Участники-полки] where [№ полка] NOT LIKE " & mystr2 & "*ф" & mystr2 & " AND ([№ игры ] =" & Me![Поле9] & " );")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

Me![Поле62] = Rez![Номер]

myQ.Close

DoCmd.DeleteObject acQuery, "Counter"

Rez.Close

'французы

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ полка])As номер From [Участники-полки] where [№ полка] LIKE " & mystr2 & "*ф" & mystr2 & " AND [№ игры ] =" & Me![Поле9] & " ;")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

Me![Поле64] = Rez![Номер]

myQ.Close

DoCmd.DeleteObject acQuery, "Counter"

Rez.Close

'люди

Set myQ = myDb.CreateQueryDef("Counter", "Select Count([№ бойца])As номер From [Участники-бойцы] where [№ игры ] =" & Me![Поле9] & " ;")

Set myQ = myDb.QueryDefs![Counter]

Set Rez = myQ.OpenRecordset()

Me![Поле66] = Rez![Номер]

myQ.Close

DoCmd.DeleteObject acQuery, "Counter"

Rez.Close

Else

MsgBox ("отсутствуют данные об игре!")

Me![Поле60] = 0

Me![Поле62] = 0

Me![Поле64] = 0

Me![Поле66] = 0

End If

End Sub

Private Sub Кнопка30_Click()

On Error GoTo Err_Кнопка30_Click

DoCmd.Close

Exit_Кнопка30_Click:

Exit Sub

Err_Кнопка30_Click:

MsgBox Err.Description

Resume Exit_Кнопка30_Click

End Sub

Private Sub Кнопка69_Click()

On Error GoTo Err_Кнопка69_Click

Dim myDb As Database

Dim myQ As QueryDef

Dim RezWithNumberOf As Recordset

Dim mystr As Variant

Dim mystr2 As Variant

nomerIgry = [Поле9]

mystr2 = """"

mystr = Me![русские в игре]![№ полка]

Set myDb = CurrentDb

Set myQ = myDb.CreateQueryDef("Polki2", "SELECT * FROM Бойцы WHERE [Полк]=" & mystr2 & mystr & mystr2 & " AND [№] in (SELECT [№ бойца] FROM [Участники-бойцы] WHERE [Участники-бойцы].[№ игры]=" & Me![Поле9] & ");") 'And Me![Участники-полки]![№ полка];")

stLinkCriteria = "№ =" & mystr2 & mystr & mystr2

DoCmd.OpenForm "полки-состав на выходе", , , stLinkCriteria

Exit_Кнопка69_Click:

Exit Sub

Err_Кнопка69_Click:

MsgBox Err.Description

MsgBox (Str(Err.Number))

MsgBox (Err.Source)

Resume Exit_Кнопка69_Click

End Sub

Private Sub Кнопка71_Click()

On Error GoTo Err_Кнопка69_Click

Dim myDb As Database

Dim myQ As QueryDef

Dim RezWithNumberOf As Recordset

Dim mystr As Variant

Dim mystr2 As Variant

nomerIgry = [Поле9]

mystr2 = """"

mystr = Me![французы в игре]![№ полка]

Set myDb = CurrentDb

Set myQ = myDb.CreateQueryDef("Polki2", "SELECT * FROM Бойцы WHERE [Полк]=" & mystr2 & mystr & mystr2 & " AND [№] in (SELECT [№ бойца] FROM [Участники-бойцы] WHERE [Участники-бойцы].[№ игры]=" & Me![Поле9] & ");") 'And Me![Участники-полки]![№ полка];")

stLinkCriteria = "№ =" & mystr2 & mystr & mystr2

DoCmd.OpenForm "полки-состав на выходе", , , stLinkCriteria

Exit_Кнопка69_Click:

Exit Sub

Err_Кнопка69_Click:

MsgBox Err.Description

MsgBox (Str(Err.Number))

MsgBox (Err.Source)

Resume Exit_Кнопка69_Click

End Sub