FrmAddClass

Код:

Public dbOpen As Database

Public NewTbl As TableDef

Public fld As Field

Dim a As String

Private Sub AddSubjClass_Click()

Dim Y As Integer

On Error GoTo eh

Dim cl As String 'переменная для класса

If Text3.Text = " " Then

MsgBox " Вы не ввели предмет", vbInformation, " Ввод предмета"

Exit Sub

End If

cl = InputBox(" Введите класс: ", " Добавление предмета в класс")

Set dbOpen = OpenDatabase(" c: \Program Files\SchoolDB\SchoolDB.mdb")

Set NewTbl = dbOpen.TableDefs(cl)

'проверка предмета на уникальность

Y = AddSubjControl()

If Y = 1 Then

MsgBox " Повторный ввод предмета " & UCase(Text3.Text), vbInformation, " Контроль ввода предметов"

Exit Sub

End If

'добавляем поле к таблице

With NewTbl

.Fields.Append.CreateField(Text3.Text, dbText)

End With

dbOpen.Close

MsgBox " Предмет " & Text3.Text & " успешно добавлен в класс " & cl

Exit Sub

eh:

If Err.Number = 3265 Then MsgBox " Такого класса не существует", vbCritical, " Ошибка"

End Sub

Private Sub AddSubjList_Click()

If Text1.Text < > " " Then

List2.AddItem Text1.Text

End If

End Sub

Private Sub cmdAdd_Click()

'заполнение второго списка из первого

If List1.Text < > " " Then

List2.AddItem List1.Text

Text2.Enabled = True

Text2.BackColor = vbWhite

End If

End Sub

Private Sub cmdCreateClass_Click()

Dim Y As Integer

On Error GoTo eh

If List2.ListCount = 0 Then MsgBox " Невозможно создать класс без предметов", vbExclamation, " Обратитесь к врачу": Exit Sub

'проверка предмета на уникальность

Y = TestList

If Y = 1 Then

MsgBox " Повторный ввод предмета " & UCase(a), vbInformation, " Контроль ввода предметов"

Exit Sub

End If

mmm = MsgBox(" Будет создан класс с " & List2.ListCount & " предметами", _

vbInformation + vbOKCancel, " SoftMaster")

If mmm = vbOK Then

If List2.List(0) = " " Then MsgBox " Вы не выбрали ни одного предмета",, " Ошибка"

Set dbOpen = OpenDatabase(" c: \Program Files\SchoolDB\SchoolDB.mdb")

'создается новая таблица для класса

Set NewTbl = dbOpen.CreateTableDef(Trim(Text2.Text))

'добавляем начальные (одинаковые для всех) поля в таблицу

With NewTbl

.Fields.Append.CreateField(" Фамилия", dbText, 30)

.Fields.Append.CreateField(" Имя", dbText, 30)

.Fields.Append.CreateField(" Отчество", dbText, 30)

.Fields.Append.CreateField(" Пол", dbText, 2)

.Fields.Append.CreateField(" Номер ЛД", dbText, 7)

.Fields.Append.CreateField(" Дата рождения", dbDate)

.Fields.Append.CreateField(" Адрес", dbText)

.Fields.Append.CreateField(" Телефон", dbText, 10)

.Fields.Append.CreateField(" Зодиак", dbText, 10)

.Fields.Append.CreateField(" Гр_здор", dbText, 5)

.Fields.Append.CreateField(" Физ_гр", dbText, 5)

.Fields.Append.CreateField(" Врач", dbText, 100)

.Fields.Append.CreateField(" Отец", dbText, 50)

.Fields.Append.CreateField(" Место работы отца", dbText, 100)

.Fields.Append.CreateField(" Должность отца", dbText, 100)

.Fields.Append.CreateField(" Телефон отца", dbText, 10)

.Fields.Append.CreateField(" Мать", dbText, 50)

.Fields.Append.CreateField(" Место работы матери", dbText, 100)

.Fields.Append.CreateField(" Должность матери", dbText, 100)

.Fields.Append.CreateField(" Телефон матери", dbText, 10)

'длбавляем таблицу в базу

dbOpen.TableDefs.Append NewTbl

End With

cmdCreateClass.Enabled = False

MsgBox " Класс " & Text2.Text & " успешно создан",, " Создание класса"

'создаем поля для предметов из выбранных

With NewTbl

For i = 0 To List2.ListCount - 1

.Fields.Append.CreateField(List2.List(i), dbText)

Next i

dbOpen.TableDefs.Append NewTbl

End With

Else: Exit Sub

End If

dbOpen.Close

Exit Sub

eh:

If Err.Number = 3010 Then

MsgBox " Класс " & Text2.Text & " уже существует.", vbInformation, " Задайте другое имя"

End If

End Sub

Private Sub cmdOK_Click()

If IsNumeric(Right$(Text2.Text, 1)) Then

MsgBox " Какой это из " & Text2.Text & " -ых классов? ", vbQuestion, " Некорректный ввод"

Text2.SetFocus

Exit Sub

End If

cmdCreateClass.Caption = " СОЗДАТЬ КЛАСС " & Text2.Text _

& " C НОВЫМИ ПРЕДМЕТАМИ"

If Text2.Text = " " Then Exit Sub

cmdCreateClass.Enabled = True

End Sub

Private Sub cmdRemove_Click()

On Error Resume Next

List2.RemoveItem (List2.ListIndex)

End Sub

Private Sub DelClass_Click()

On Error GoTo eh

'удаление класса

Dim cl As String, ans As String

ans = MsgBox(" Are you sure??? ", vbQuestion + vbOKCancel, " Удаленного не воротишь...")

If ans = vbOK Then

cl = InputBox(" Введите имя удаляемого класса: ", " Удаление класса")

Set dbOpen = OpenDatabase(" c: \Program Files\SchoolDB\SchoolDB.mdb")

Set NewTbl = dbOpen.TableDefs(cl)

MsgBox " Класс < " & NewTbl.Name & " > удален", vbInformation, " SoftMaster"

'удаляем класс (на самом деле даем ему другое имя)

NewTbl.Name = " архив" & NewTbl.Name

End If

Exit Sub

eh:

If Err.Number = 3265 Then

MsgBox " Такого класса не существует", vbInformation, " Ошибка запроса"

End If

End Sub

Private Sub Form_Load()

On Error Resume Next

frmParol.CenterForm Me

Dim Sbj As String

'открываем текстовый файл со всеми предметами и заполняем или список1

Open " c: \Program Files\SchoolDB\subjects.txt" For Input As #2

Do While Not EOF(2)

Line Input #2, Sbj

List1.AddItem Sbj

Loop

End Sub

Private Sub RemoveAllList2_Click()

List2.Clear

Text2.Enabled = False

Text2.BackColor = vbButtonFace

End Sub

Private Sub SubjFromClass_Click()

frmSubjFromClass.Show

End Sub

Private Sub Text2_GotFocus()

cmdOK.Enabled = True

End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)

'ограничение ввода недопустимых символов

Select Case Chr$(KeyAscii)

Case " "

GoTo cs

Case Chr$(34)

GoTo cs

Case "."

GoTo cs

Case ", "

GoTo cs

Case " < "

GoTo cs

Case " > "

GoTo cs

Case " '"

GoTo cs

End Select

Exit Sub

cs:

MsgBox " Недопустимый символ < " & Chr$(KeyAscii) & " > ", vbInformation, " Ошибка ввода"

Text2.SetFocus

Text2.Text = " "

SendKeys " {BS}"

End Sub

Public Static Function TestList()

TestList = 0

'проверка списка на повторяемость предметов

For i = 0 To List2.ListCount - 1

a = List2.List(i)

For j = i + 1 To List2.ListCount - 1

If a = List2.List(j) Then TestList = 1

Next j

Next i

End Function

Public Static Function AddSubjControl()

'проверка предметов в классе на повторяемость

AddSubjControl = 0

For i = 0 To NewTbl.Fields.Count - 1

Set fld = NewTbl.Fields(i)

If Text3.Text = fld.Name Then AddSubjControl = 1

Next i

End Function