Проект «Школьный журнал» (пример создания и работы с базой данных)

Предлагаемый проект предназначен для демонстрации и анализа работы программы. Рекомендую внимательно изучить код, так как Вам предстоит создать нечто подобное самостоятельно (в упрощенном варианте).

Проект включает в себя следующие формы:

frmParol

Код:

Dim Parol As String

'процедура центрирования формы

Public Sub CenterForm(frm As Form)

frm.Move (Screen.Width - frm.Width) / 2, (Screen.Height - frm.Height) / 2

End Sub

Private Sub cmdOK_Click()

'проверка пароля

If Text1.Text <> Parol Then

MsgBox "В доступе отказано", vbCritical, "Школьная БД"

Text1.Text = "": Text1.SetFocus

Exit Sub

End If

frmHello.Show

Unload Me

End Sub

Private Sub Form_Load()

On Error GoTo eh

CenterForm Me

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

Open "c:\windows\system\prl.txt" For Input As #1

Input #1, Parol

Close #1

Exit Sub

eh:

If Err.Number = 53 Then

MsgBox "Список паролей не найден", vbInformation, "Школьная БД"

End

End If

End Sub

Private Sub Text1_Change()

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

If Len(Text1.Text) = 3 Then cmdOK.SetFocus

If Len(Text1.Text) = 4 Then Text1.Text = ""

End Sub

frmHello

Код:

Dim db As Database

Private Sub cmdAddClass_Click()

frmAddClass.Show

End Sub

Private Sub Form_Load()

On Error GoTo eh

'центрирование формы

frmParol.CenterForm Me

'создаем базу данных по известному компьютеру адресу

Set db = DBEngine.Workspaces(0).CreateDatabase _

("c:\Program Files\SchoolDB\SchoolDB.mdb", dbLangGeneral)

Exit Sub

eh:

If Err.Number = 3044 Then

MsgBox "Не могу создать базу данных - " & _

vbCrLf & "в папке Program Files нет папки SchoolDB" & _

vbCrLf & "Создайте папку ...", vbInformation, "Ошибка создания базы"

End If

If Err.Number = 3204 Then Exit Sub

End Sub

Private Sub OpenClass_Click()

frmClasses.Show

End Sub

frmClasses

Код:

Public db As Database

Public tbl As TableDef

Dim fld As Field

Private Sub cmdSelectClass_Click()

On Error GoTo eh

Dim subj As String

'берется класс из списка

subj = List1.Text

'к переменной привязывается выбранная таблица (класс)

Set tbl = db.TableDefs(subj)

frmSelectedClass.Show

Exit Sub

eh:

If Err.Number = 3265 Then MsgBox "Вы ничего не выбрали", , "Сообщение"

End Sub

Private Sub Form_Load()

frmParol.CenterForm Me

'открывается база данных

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

'заполняется лист списком классов (имена таблиц из базы)

For i = 0 To db.TableDefs.Count - 1

Set tbl = db.TableDefs(i)

'если первый символ - число, то берем таблицу (там какие-то внутренние

'таблицы иначе добавляются в список

If IsNumeric(Left$(tbl.Name, 1)) Then List1.AddItem tbl.Name

Next i

'выделить первую строку в списке

List1.Selected(0) = True

End Sub

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

frmSelectedClass

Код:

Dim fld As Field

Dim rs As Recordset

Private Sub cmdExit_Click()

otv = MsgBox("Высохранили сделанные изменения?", vbQuestion + vbOKCancel, "SoftMaster")

If otv = vbOK Then

Unload Me

End If

End Sub

Private Sub cmdFind_Click()

On Error Resume Next

'поиска по началу фамилии

Dim famFind As String

famFind = InputBox("Введите фамилию для поиска", _

"Поиск по фамилии")

Data1.Recordset.FindFirst "[Фамилия] like '" & famFind & "*'"

End Sub

Private Sub cmdZodiak_Click()

On Error GoTo eh

'определение знака зодиака

Dim Day As Date

Dim DayBegin As Date

Dim DayEnd As Date

Dim Znak As String

Znak = Text6(1)

'значение года ".85" - чистая фикция, он нужен только для

'сохранения формата даты

Day = CDate(Left$(Znak, 5) + ".85")

If Day >= CDate("21.3.85") And Day <= CDate("20.4.85") Then Text6(4) = "Овен"

If Day >= CDate("21.4.85") And Day <= CDate("20.5.85") Then Text6(4) = "Телец"

If Day >= CDate("21.5.85") And Day <= CDate("21.6.85") Then Text6(4) = "Близнецы"

If Day >= CDate("22.6.85") And Day <= CDate("22.7.85") Then Text6(4) = "Рак"

If Day >= CDate("23.7.85") And Day <= CDate("23.8.85") Then Text6(4) = "Лев"

If Day >= CDate("24.8.85") And Day <= CDate("23.9.85") Then Text6(4) = "Дева"

If Day >= CDate("24.9.85") And Day <= CDate("23.10.85") Then Text6(4) = "Весы"

If Day >= CDate("24.10.85") And Day <= CDate("22.11.85") Then Text6(4) = "Скорпион"

If Day >= CDate("23.11.85") And Day <= CDate("21.12.85") Then Text6(4) = "Стрелец"

If Day >= CDate("22.12.85") And Day <= CDate("20.1.85") Then Text6(4) = "Козерог"

If Day >= CDate("21.1.85") And Day <= CDate("19.2.85") Then Text6(4) = "Водолей"

If Day >= CDate("20.2.85") And Day <= CDate("20.3.85") Then Text6(4) = "Рыбы"

Exit Sub

eh:

If Err.Number = 13 Then

MsgBox "Введите дату рождения в виде ДД.ММ.ГГ", vbInformation, "Ошибка"

Text6(1).SetFocus

End If

End Sub

Private Sub Data1_Reposition()

'отражает номер текуще записи в Data

Data1.Caption = "№ " & Data1.Recordset.AbsolutePosition + 1 & _

" из " & Data1.Recordset.RecordCount

'удаляет средние значения при переходе к другой записи

Call DelLabels

End Sub

Private Sub DeleteRec_Click()

On Error GoTo eh

ans = MsgBox("Запись будет удалена совсем. Вы уверены?", vbQuestion + vbOKCancel, "SoftMaster")

If ans = vbOK Then

With Data1.Recordset

.Delete

.MoveNext

If .EOF Then .MoveLast

End With

End If

Call DelLabels

Exit Sub

eh:

If Err.Number = 3021 Then MsgBox "Больше нет текущих записей", vbInformation, "База данных"

End Sub

Private Sub Form_Load()

frmParol.CenterForm Me

Me.Caption = "Выбранный класс - " & frmClasses.tbl.Name

Data1.RecordSource = frmClasses.tbl.Name

Text1.DataField = "Фамилия"

Text2.DataField = "Имя"

Text3.DataField = "Отчество"

'************ определяем количество предметов в классе *********

Dim Num As Integer

'количество предметов всего

Num = frmClasses.tbl.Fields.Count - 1

'номер первого предмета в таблице = 20(без ФИО и начальных для всех полей)

For i = 4 To 8

Set fld = frmClasses.tbl.Fields(i)

Text6(i - 4).DataField = fld.Name

Next i

For i = 12 To 19

Set fld = frmClasses.tbl.Fields(i)

Text5(i - 12).DataField = fld.Name

Next i

For i = 20 To Num

Set fld = frmClasses.tbl.Fields(i)

Label4(i - 20).Caption = fld.Name

Text4(i - 20).Visible = True

Метка1(i - 20).Visible = True

Text4(i - 20).DataField = fld.Name

Next i

Set fld = frmClasses.tbl.Fields(3)

Combo1.DataField = fld.Name

Set fld = frmClasses.tbl.Fields(9)

Combo2.DataField = fld.Name

Set fld = frmClasses.tbl.Fields(10)

Combo3.DataField = fld.Name

Set fld = frmClasses.tbl.Fields(11)

Text7.DataField = fld.Name

End Sub

Private Sub NewRec_Click()

Call DelLabels

Data1.Recordset.AddNew

End Sub

Private Sub Save_Click()

Data1.UpdateRecord

End Sub

Private Sub ShowAllStudents_Click()

frmAllStudents.Show

End Sub

Private Sub Text4_Change(Index As Integer)

'чтобы игнорировать деление на ноль

On Error Resume Next

'вычисление среднего значения

For i = 0 To 19

If Text4(i).DataChanged = True Then

If Text4(i) = "" Then Метка1(i) = ""

Метка1(i) = Summa(Text4(i)) / Len(Text4(i))

End If

Next

End Sub

Public Function Summa(T)

'сумма всех оценок

Dim sum As Integer

For i = 1 To Len(T)

sum = sum + Val(Mid$(T, i, 1))

Next

Summa = sum

End Function

Private Sub Text4_KeyPress(Index As Integer, KeyAscii As Integer)

'контроль ввода оценок (только оценки)

Select Case KeyAscii

'разрешить нажатие этих клавиш

Case Asc("<")

Case Asc(">")

Case Asc(Chr$(8)) 'это BackSpace

'запретить нажатие всех, кроме 1,2,3,4,5

Case Is < Asc("1")

KeyAscii = 0

Case Is > Asc("5")

KeyAscii = 0

End Select

End Sub

Public Sub DelLabels()

For i = 0 To 19

Метка1(i) = ""

Next i

End Sub

Private Sub Метка1_Click(Index As Integer)

'чтобы игнорировать деление на ноль

On Error Resume Next

For i = 0 To 19

If Text4(i).Visible = True Then

If Text4(i) = "" Then Метка1(i) = ""

Метка1(i) = Summa(Text4(i)) / Len(Text4(i))

End If

Next

End Sub

frmAllStudents

Форма должна разворачиваться на весь экран.

Код:

Private Sub Form_Load()

'показать всех

frmParol.CenterForm Me

Dim rec As Recordset

Dim strSQL As String, SelClass As String

Data1.RecordSource = frmClasses.tbl.Name

Me.WindowState = 2

strSQL = "SELECT * from [" & frmClasses.tbl.Name & "] order by [Фамилия] asc"

Set rec = frmClasses.db.OpenRecordset(strSQL)

Set Data1.Recordset = rec

End Sub

frmSubjFromClass

Код:

Dim db As Database

Dim tbl As TableDef

Dim fld As Field

Private Sub Command1_Click()

On Error GoTo eh

Dim subj As String

subj = List1.Text

Set tbl = db.TableDefs(subj)

'добавляем предметы в лист из существующего класса

For i = 20 To tbl.Fields.Count - 1

Set fld = tbl.Fields(i)

frmAddClass.List2.AddItem fld.Name

Next i

frmAddClass.Text2.Enabled = True

frmAddClass.Text2.BackColor = vbWhite

db.Close

Unload Me

Exit Sub

eh:

If Err.Number = 3265 Then MsgBox "Вы ничего не выбрали", , "Сообщение"

End Sub

Private Sub Form_Load()

frmParol.CenterForm Me

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

For i = 0 To db.TableDefs.Count - 1

Set tbl = db.TableDefs(i)

If IsNumeric(Left$(tbl.Name, 1)) Then List1.AddItem tbl.Name

Next i

End Sub