Рефераты

Главная

Начертательная геометрия

Оккультизм и уфология

Педагогика

Полиграфия

Политология

Программирование
компьютеры и кибернетика

Производство и технологии

Социальная работа

Начертательная геометрия

Не сортированные

Таможенная система

Теория государства и права

Арбитражный процесс

Нотариат

Менеджмент

Металлургия

Минералогия

Москвоведение

Создание базы данных о студентах ВУЗа

f OpenFile <> "" Then Me.Caption = strName + " - " + OpenFile

End Sub

Public Sub Save(intSaveAs As Byte)

Dim strФильтр As String

If intSaveAs = 0 And OpenFile <> "" Then

If Dir(OpenFile) = Right$(OpenFile, Len(OpenFile) - Len(ОтрезИмя(OpenFile))) Then

Kill OpenFile

Else

OpenFile = ""

MsgBox "Сохраненный файл был удален или поврежден. Попробуйте сохранить еще раз", vbCritical + vbOKOnly, strName

Exit Sub

End If

Open OpenFile For Random As 1 Len = Len(Zapis)

For i = 0 To lstZapis(1).ListCount - 1

Zapis.Студент = lstZapis(0).List(i)

Zapis.Группа = lstZapis(1).List(i)

Zapis.Курс = lstZapis(2).List(i)

Zapis.Работа = lstZapis(3).List(i)

Zapis.Дата_сдачи = lstZapis(4).List(i)

Zapis.Оценка = lstZapis(5).List(i)

Zapis.Дата_выдачи = lstZapis(6).List(i)

Put #1, i + 1, Zapis

Close #1

Else

strФильтр = "Файлы " + strName + " (*." + strРасширение + ")|*." + strРасширение + "|"

cdl1.Filter = strФильтр

cdl1.Action = 2

If cdl1.FileName <> "" Then

OpenFile = cdl1.FileName

If Dir(OpenFile) = Right$(OpenFile, Len(OpenFile) - Len(ОтрезИмя(OpenFile))) Then

If MsgBox("Файл уже существует. Перезаписать?", vbQuestion + vbYesNo, strName) = vbNo Then Exit Sub

End If

Open OpenFile For Random As 1 Len = Len(Zapis)

For i = 0 To lstZapis(1).ListCount - 1

Zapis.Студент = lstZapis(0).List(i)

Zapis.Группа = lstZapis(1).List(i)

Zapis.Курс = lstZapis(2).List(i)

Zapis.Работа = lstZapis(3).List(i)

Zapis.Дата_сдачи = lstZapis(4).List(i)

Zapis.Оценка = lstZapis(5).List(i)

Zapis.Дата_выдачи = lstZapis(6).List(i)

Put #1, i + 1, Zapis

Close #1

End If

If OpenFile <> "" Then Me.Caption = strName + " - " + OpenFile

End Sub

Public Sub Edit(strType As String, lngN As Long)

If strType = "Add" Then

frmAdd.Show 1

End If

If strType = "Del" Then

If MsgBox("Вы действительно хотите удалить эту запись?", vbQuestion + vbYesNo) = vbNo Then Exit Sub

For i = 0 To 6

lstZapis(i).RemoveItem (lngN)

End If

If strType = "Edt" Then

lngNumberOfEdit = lngN

frmEdit.txt1.Text = lstZapis(0).List(lngN)

frmEdit.txt2.Text = lstZapis(1).List(lngN)

frmEdit.txt3.Text = lstZapis(2).List(lngN)

frmEdit.txt4.Text = lstZapis(3).List(lngN)

frmEdit.txt5.Text = lstZapis(4).List(lngN)

frmEdit.txt6.Text = lstZapis(5).List(lngN)

frmEdit.txt7.Text = lstZapis(6).List(lngN)

frmEdit.Show 1

End If

End Sub

Public Sub Search(strType As String)

Dim strЗапрос As String

Dim m As Byte

Dim boolF As Boolean

For i = 0 To 6

frmSearch.lstZapis(i).Clear

frmSearch.lstNumbers.Clear

strЗапрос = ""

intPole = -1

If strType = "Fst" Then

strSearch = InputBox("Введите первую букву записи выделенного поля (регистр не учитывается)", "Поиск по первой букве", "а")

For i = 0 To 6

If optPole(i).Value = True Then intPole = i

If intPole = -1 Then MsgBox "Не задано поле для поиска", vbCritical + vbOKOnly, strName: Exit Sub

For i = 0 To lstZapis(intPole).ListCount - 1

If UCase(Left(lstZapis(intPole).List(i), 1)) = UCase(strSearch) Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

If strSearch <> "" Then frmSearch.Show 1

End If

End Sub

Public Sub Help()

frmHelp.Show

End Sub

Public Sub Sort(strType As String, pole As Long)

Dim lng1 As Long

Dim lng2 As Long

If strType = "Up" Then

For lng1 = 0 To lstZapis(pole).ListCount - 1

For lng2 = lng1 To lstZapis(pole).ListCount - 1

If pole <> 4 And pole <> 6 Then

If lstZapis(pole).List(lng1) > lstZapis(pole).List(lng2) Then

Call Замена(lng1, lng2)

End If

Else

If Data_Sort(lstZapis(pole).List(lng1), lstZapis(pole).List(lng2)) = 1 Then

Call Замена(lng1, lng2)

End If

If strType = "Dwn" Then

For lng1 = 0 To lstZapis(pole).ListCount - 1

For lng2 = lng1 To lstZapis(pole).ListCount - 1

If pole <> 4 And pole <> 6 Then

If lstZapis(pole).List(lng1) < lstZapis(pole).List(lng2) Then

Call Замена(lng1, lng2)

End If

Else

If Data_Sort(lstZapis(pole).List(lng1), lstZapis(pole).List(lng2)) = 2 Then

Call Замена(lng1, lng2)

End If

End Sub

Public Sub Format(strType As String)

If strType = "Font" Or strType = "Size" Then

cdl1.Flags = cdlCFScreenFonts

cdl1.Action = 4

For i = 0 To 6

If cdl1.FontSize <> 0 Then lstZapis(i).FontSize = cdl1.FontSize

If Trim(cdl1.FontName) <> "" Then lstZapis(i).FontName = cdl1.FontName

lstZapis(i).FontBold = cdl1.FontBold

lstZapis(i).FontItalic = cdl1.FontItalic

lstZapis(i).FontStrikethru = cdl1.FontStrikethru

lstZapis(i).FontUnderline = cdl1.FontUnderline

End If

If strType = "Color" Then

cdl1.Action = 3

For i = 0 To 6

lstZapis(i).ForeColor = cdl1.Color

End If

End Sub

Public Function Quite() As Boolean

If MsgBox("Вы уверены, что хотите выйти?" + vbNewLine + "Все несохраненные данные будут потеряны", vbQuestion + vbYesNo, strName) = vbYes Then Quite = True Else Quite = False

End Function

Private Sub chkDop_Click()

If chkDop.Value = 0 Then

boolDop = False

frmDatabase.Width = 8625

frmDatabase.Picture = imgMain1.Picture

chkDop.Width = 529

lstZapis(6).Visible = False

optPole(6).Visible = False

mnuLongest.Visible = False

mnuTwoMonth.Visible = False

StatusBar1.Panels(1).Width = 500

Else

boolDop = True

frmDatabase.Picture = imgMain0.Picture

frmDatabase.Width = 10050

chkDop.Width = 617

lstZapis(6).Visible = True

optPole(6).Visible = True

mnuLongest.Visible = True

mnuTwoMonth.Visible = True

StatusBar1.Panels(1).Width = 600

End If

End Sub

Private Sub cmdTool_Click(Index As Integer)

If Index = 0 Then Call Create

If Index = 1 Then Call Open_File

If Index = 2 Then Call Save(0)

If Index = 5 Then

If lstZapis(1).ListIndex <> -1 Then Call Edit("Del", lstZapis(1).ListIndex)

End If

If Index = 4 Then

If lstZapis(1).ListIndex <> -1 Then Call Edit("Edt", lstZapis(1).ListIndex)

End If

If Index = 3 Then Call Edit("Add", 0)

If Index = 7 Then Call Search("Fst")

If Index = 6 Then

If lstZapis(0).ListCount > 0 Then frmDiagramms.Show

End If

If Index = 8 Then Call Help

If Index = 10 Then

For i = 0 To 6

If optPole(i).Value = True Then Call Sort("Up", i)

End If

If Index = 11 Then

For i = 0 To 6

If optPole(i).Value = True Then Call Sort("Dwn", i)

End If

If Index = 9 Then

If Quite = True Then End

End If

For i = 0 To 11

cmdTool(i).Default = False

End Sub

Private Sub Form_Load()

Call init

mnuLongest.Visible = True

mnuTwoMonth.Visible = True

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

For i = 0 To 6

optPole(i).Value = False

If Button = 2 Then

PopupMenu mnuFormat

End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

If Quite = False Then Cancel = 1

End Sub

Private Sub Form_Unload(Cancel As Integer)

End

End Sub

Private Sub lstZapis_Click(Index As Integer)

For i = 0 To 6

lstZapis(i).ListIndex = lstZapis(Index).ListIndex

End Sub

Private Sub lstZapis_DblClick(Index As Integer)

If lstZapis(1).ListIndex <> -1 Then Call Edit("Edt", lstZapis(1).ListIndex)

End Sub

Private Sub lstZapis_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

If KeyCode = 46 Then

If lstZapis(1).ListIndex <> -1 Then Call Edit("Del", lstZapis(1).ListIndex)

End If

If KeyCode = 13 Then

If lstZapis(1).ListIndex <> -1 Then Call Edit("Edt", lstZapis(1).ListIndex)

End If

End Sub

Private Sub lstZapis_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)

If Button = 1 Then

For i = 0 To 6

lstZapis(i).ListIndex = lstZapis(Index).ListIndex

End If

If Button = 2 Then

PopupMenu mnuEdit

End If

End Sub

Private Sub mnuAbout_Click()

frmAbout.Show 1

End Sub

Private Sub mnuAdd_Click()

Call Edit("Add", 0)

End Sub

Private Sub mnuChange_Click()

Call Edit("Edt", lstZapis(0).ListIndex)

End Sub

Private Sub mnuColor_Click()

Call Format("Color")

End Sub

Private Sub mnuCreate_Click()

Call Create

End Sub

Private Sub mnuDelete_Click()

Call Edit("Del", lstZapis(0).ListIndex)

End Sub

Private Sub mnuEdit_Click()

If lstZapis(1).ListIndex = -1 Then

mnuDelete.Enabled = False

mnuChange.Enabled = False

Else

mnuDelete = True

mnuChange.Enabled = True

End If

End Sub

Private Sub mnuDown_Click()

For i = 0 To 6

If optPole(i).Value = True Then Call Sort("Dwn", i)

End Sub

Private Sub mnuExit_Click()

If Quite = True Then End

End Sub

Private Sub mnuFirst_Click()

Call Search("Fst")

End Sub

Private Sub mnuFont_Click()

Call Format("Font")

End Sub

Private Sub mnuHelper_Click()

frmHelp.Show

End Sub

Private Sub mnuLongest_Click()

Dim max As Long

For j = 0 To 6

frmSearch.lstZapis(j).Clear

frmSearch.lstNumbers.Clear

max = 0

For i = 0 To lstZapis(0).ListCount - 1

If Date_raz(lstZapis(4).List(i), lstZapis(6).List(i)) > max Then max = Date_raz(lstZapis(4).List(i), lstZapis(6).List(i))

For i = 0 To lstZapis(0).ListCount - 1

If Date_raz(lstZapis(4).List(i), lstZapis(6).List(i)) = max Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Private Sub mnuOpen_Click()

Call Open_File

End Sub

Private Sub mnuSave_Click()

Call Save(0)

End Sub

Private Sub mnuSaveAs_Click()

Call Save(1)

End Sub

Private Sub mnuSearch_Click()

If lstZapis(1).ListIndex = -1 Then

mnuZap1.Enabled = False

mnuZap2.Enabled = False

mnuZap4.Enabled = False

Else

mnuZap1.Enabled = True

mnuZap2.Enabled = True

mnuZap4.Enabled = True

End If

End Sub

Private Sub mnuSize_Click()

Call Format("Size")

End Sub

Private Sub mnuTwoMonth_Click()

For i = 0 To 6

frmSearch.lstZapis(i).Clear

frmSearch.lstNumbers.Clear

For i = 0 To lstZapis(0).ListCount - 1

If Date_raz(lstZapis(4).List(i), lstZapis(6).List(i)) > 60 Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Private Sub mnuUp_Click()

For i = 0 To 6

If optPole(i).Value = True Then Call Sort("Up", i)

End Sub

Private Sub mnuZap1_Click()

Dim strStud As String

strStud = lstZapis(0).Text

For i = 0 To 6

frmSearch.lstZapis(i).Clear

frmSearch.lstNumbers.Clear

For i = 0 To lstZapis(1).ListCount - 1

If lstZapis(0).List(i) = strStud Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Private Sub mnuZap2_Click()

Dim strMounth As String

Dim strGroop As String

For i = 0 To 6

frmSearch.lstZapis(i).Clear

frmSearch.lstNumbers.Clear

strGroop = lstZapis(1).Text

strMounth = InputBox("Введите номер месяца", "За какой месяц?", Mid(Date, 4, 2))

If Number(strMounth, False, True, 1, 12) = False Then

MsgBox NumError, vbCritical + vbOKOnly, strName

Exit Sub

End If

For i = 0 To lstZapis(0).ListCount - 1

If lstZapis(1).List(i) = strGroop Then

If (CInt(Mid(lstZapis(4).List(i), 4, 2)) = CInt(strMounth)) And (lstZapis(1).List(i) = strGroop) Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Private Sub mnuZap3_Click()

Dim stud As String

Dim n As Integer

Dim k

k = 0

'Подготовка формы поиска

For n = 0 To 6

frmSearch.lstZapis(n).Clear

frmSearch.lstNumbers.AddItem i

'Выбор студента

For i = 0 To lstZapis(0).ListCount - 1

k = 0: lstDates.Clear

stud = lstZapis(0).List(i)

'Внесение всех его дат сдачи в список дат

For j = 0 To lstZapis(0).ListCount - 1

If lstZapis(0).List(j) = stud Then lstDates.AddItem lstZapis(4).List(i)

'Проверка дат на совпадение

For n = 0 To lstDates.ListCount - 1

For j = 0 To lstDates.ListCount - 1

'Если совпадает, увеличиваем счетчик на 1

If lstDates.List(n) = lstDates.List(j) And n <> j Then k = k + 1

'Если больше 2-х одинаковых, вносим в результат

If k > 2 Then

For n = 0 To 6

frmSearch.lstZapis(n).AddItem lstZapis(n).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Private Sub mnuZap4_Click()

Dim strKurs As String

strKurs = lstZapis(2).Text

For i = 0 To 6

frmSearch.lstZapis(i).Clear

frmSearch.lstNumbers.Clear

For i = 0 To lstZapis(1).ListCount - 1

If (lstZapis(5).List(i) = "4" Or lstZapis(5).List(i) = "5") And (lstZapis(2).List(i) = strKurs) Then

For j = 0 To 6

frmSearch.lstZapis(j).AddItem lstZapis(j).List(i)

frmSearch.lstNumbers.AddItem i

End If

frmSearch.Show 1

End Sub

Public Sub Замена(lngЧто As Long, lngНа As Long)

Dim str1 As String

Dim int3 As Byte

For int3 = 0 To 6

str1 = lstZapis(int3).List(lngНа)

lstZapis(int3).List(lngНа) = lstZapis(int3).List(lngЧто)

lstZapis(int3).List(lngЧто) = str1

End Sub

Public Function ОтрезИмя(Путь As String) As String

Dim b As String

j = 1

Do While Left$(Right$(Путь, j), 1) <> "\"

j = j + 1

Loop

ОтрезИмя = Left$(Путь, Len(Путь) - j + 1)

'n = n + 1

End Function

Public Function Data_Sort(dat1 As String, dat2 As String) As Byte

If CInt(Right$(dat1, 4)) > CInt(Right$(dat2, 4)) Then Data_Sort = 1

If CInt(Right$(dat1, 4)) < CInt(Right$(dat2, 4)) Then Data_Sort = 2

If CInt(Right$(dat1, 4)) = CInt(Right$(dat2, 4)) Then

If CInt(Mid$(dat1, 4, 2)) > CInt(Mid$(dat2, 4, 2)) Then Data_Sort = 1

If CInt(Mid$(dat1, 4, 2)) < CInt(Mid$(dat2, 4, 2)) Then Data_Sort = 2

If CInt(Mid$(dat1, 4, 2)) = CInt(Mid$(dat2, 4, 2)) Then

If CInt(Left$(dat1, 2)) > CInt(Left$(dat2, 2)) Then Data_Sort = 1

If CInt(Left$(dat1, 2)) < CInt(Left$(dat2, 2)) Then Data_Sort = 2

If CInt(Left$(dat1, 2)) = CInt(Left$(dat2, 2)) Then Data_Sort = 3

End If

End Function

frmAdd

Dim bool5 As Boolean

Dim bool7 As Boolean

Private Sub Calendar1_Click()

If bool5 = True Then Me.txt5.Text = CStr(Calendar1.Day) + "." + CStr(Calendar1.Month) + "." + CStr(Calendar1.Year): bool5 = False

If bool7 = True Then Me.txt7.Text = CStr(Calendar1.Day) + "." + CStr(Calendar1.Month) + "." + CStr(Calendar1.Year): bool7 = False

Me.Width = 6135

Me.Picture = imgMain0.Picture

If Mid$(txt5.Text, 2, 1) = "." Then txt5.Text = "0" + txt5.Text

If Mid$(txt7.Text, 2, 1) = "." Then txt7.Text = "0" + txt7.Text

If Mid$(txt5.Text, 5, 1) = "." Then txt5.Text = Left(txt5.Text, 3) + "0" + Right(txt5.Text, 6)

If Mid$(txt7.Text, 5, 1) = "." Then txt7.Text = Left(txt7.Text, 3) + "0" + Right(txt7.Text, 6)

End Sub

Private Sub cmdAdd_Click()

If txt1.Text <> "" And txt2.Text <> "" And txt3.Text <> "" And txt4.Text <> "" And txt4.Text <> "" Then

'If Number(txt2.Text, False, True, 0, 120) = False Then

'MsgBox NumError, vbCritical + vbOKOnly, "Неверно введена группа"

'Exit Sub

'End If

If Number(txt6.Text, False, True, 0, 5) = False Then

MsgBox NumError, vbCritical + vbOKOnly, "Неверно введена оценка"

Exit Sub

End If

If (Not IsDate(txt5.Text)) Or (Not IsDate(txt7.Text)) Then

MsgBox "Дата выдачи или дата сдачи записана неверно", vbCritical + vbOKOnly, "Неверно введена дата"

Exit Sub

End If

If Date_raz(txt5.Text, txt7.Text) < 0 Then

MsgBox "Дата выдачи больше даты сдачи", vbCritical + vbOKOnly, "Неверно введена дата"

Exit Sub

End If

frmDatabase.lstZapis(0).AddItem txt1.Text

frmDatabase.lstZapis(1).AddItem txt2.Text

frmDatabase.lstZapis(2).AddItem txt3.Text

frmDatabase.lstZapis(3).AddItem txt4.Text

frmDatabase.lstZapis(4).AddItem txt5.Text

frmDatabase.lstZapis(5).AddItem txt6.Text

frmDatabase.lstZapis(6).AddItem txt7.Text

Unload Me

End If

End Sub

Private Sub Form_Load()

For i = 0 To intВсегоПолей

Me.lbl(i).Caption = strПоле(i)

Me.Icon = frmDatabase.imlButtons.ListImages(6).Picture

End Sub

Private Sub txt5_Click()

bool5 = True

bool7 = False

Me.Width = 9840

Me.Picture = imgMain1.Picture

End Sub

Private Sub txt7_Click()

bool7 = True

bool5 = False

Me.Width = 9840

Me.Picture = imgMain1.Picture

End Sub

frmEdit

Dim bool5 As Boolean

Dim bool7 As Boolean

Private Sub Calendar1_Click()

If bool5 = True Then Me.txt5.Text = CStr(Calendar1.Day) + "." + CStr(Calendar1.Month) + "." + CStr(Calendar1.Year): bool5 = False

If bool7 = True Then Me.txt7.Text = CStr(Calendar1.Day) + "." + CStr(Calendar1.Month) + "." + CStr(Calendar1.Year): bool7 = False

Me.Width = 6135

Me.Picture = imgMain0.Picture

If Mid$(txt5.Text, 2, 1) = "." Then txt5.Text = "0" + txt5.Text

If Mid$(txt7.Text, 2, 1) = "." Then txt7.Text = "0" + txt7.Text

If Mid$(txt5.Text, 5, 1) = "." Then txt5.Text = Left(txt5.Text, 3) + "0" + Right(txt5.Text, 6)

If Mid$(txt7.Text, 5, 1) = "." Then txt7.Text = Left(txt7.Text, 3) + "0" + Right(txt7.Text, 6)

End Sub

Private Sub cmdEdit_Click()

If txt1.Text <> "" And txt2.Text <> "" And txt3.Text <> "" And txt4.Text <> "" And txt4.Text <> "" Then

'If Number(txt2.Text, False, True, 0, 120) = False Then

'MsgBox NumError, vbCritical + vbOKOnly, "Неверно введена группа"

'Exit Sub

'End If

If Number(txt6.Text, False, True, 0, 5) = False Then

MsgBox NumError, vbCritical + vbOKOnly, "Неверно введена оценка"

Exit Sub

End If

If (Not IsDate(txt5.Text)) Or (Not IsDate(txt7.Text)) Then

MsgBox "Дата выдачи или дата сдачи записана неверно", vbCritical + vbOKOnly, "Неверно введена дата"

Exit Sub

End If

If Date_raz(txt5.Text, txt7.Text) < 0 Then

MsgBox "Дата выдачи больше даты сдачи", vbCritical + vbOKOnly, "Неверно введена дата"

Exit Sub

End If

frmDatabase.lstZapis(0).List(lngNumberOfEdit) = txt1.Text

frmDatabase.lstZapis(1).List(lngNumberOfEdit) = txt2.Text

frmDatabase.lstZapis(2).List(lngNumberOfEdit) = txt3.Text

frmDatabase.lstZapis(3).List(lngNumberOfEdit) = txt4.Text

frmDatabase.lstZapis(4).List(lngNumberOfEdit) = txt5.Text

frmDatabase.lstZapis(5).List(lngNumberOfEdit) = txt6.Text

frmDatabase.lstZapis(6).List(lngNumberOfEdit) = txt7.Text

Unload Me

End If

End Sub

Private Sub Form_Load()

Me.Icon = frmDatabase.imlButtons.ListImages(5).Picture

For i = 0 To intВсегоПолей

Me.lbl(i).Caption = strПоле(i)

End Sub

Private Sub txt5_Click()

bool5 = True

bool7 = False

Me.Width = 9840

Me.Picture = imgMain1.Picture

End Sub

Private Sub txt7_Click()

bool7 = True

bool5 = False

Me.Width = 9840

Me.Picture = imgMain1.Picture

End Sub

frmSearch

Private Sub cmdSave_Click()

Call Save(1)

End Sub

Private Sub Form_Activate()

If lstZapis(0).ListCount = 0 Then cmdSave.Enabled = False Else cmdSave.Enabled = True

StatusBar1.Panels(2).Text = lstZapis(0).ListCount

End Sub

Private Sub Form_Load()

For i = 0 To intВсегоПолей

Me.lbl(i).Caption = strПоле(i)

Me.Icon = frmDatabase.imlButtons.ListImages(7).Picture

End Sub

Private Sub lstZapis_Click(Index As Integer)

For i = 0 To 6

lstZapis(i).ListIndex = lstZapis(Index).ListIndex

lstNumbers.ListIndex = lstZapis(Index).ListIndex

End Sub

Private Sub lstZapis_DblClick(Index As Integer)

For i = 0 To 6

frmDatabase.lstZapis(i).ListIndex = lstNumbers.Text

Unload Me

End Sub

Private Sub lstZapis_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)

If Button = 1 Then

For i = 0 To 6

lstZapis(i).ListIndex = lstZapis(Index).ListIndex

lstNumbers.ListIndex = lstZapis(Index).ListIndex

End If

End Sub

Public Sub Save(intSaveAs As Byte)

Dim strФильтр As String

If intSaveAs = 0 And OpenFile <> "" Then

If Dir(OpenFile) = Right$(OpenFile, Len(OpenFile) - Len(ОтрезИмя(OpenFile))) Then

Kill OpenFile

Else

OpenFile = ""

MsgBox "Сохраненный файл был удален или поврежден. Попробуйте сохранить еще раз", vbCritical + vbOKOnly, strName

Exit Sub

End If

Open OpenFile For Random As 1 Len = Len(Zapis)

For i = 0 To lstZapis(1).ListCount - 1

Zapis.Студент = lstZapis(0).List(i)

Zapis.Группа = lstZapis(1).List(i)

Zapis.Курс = lstZapis(2).List(i)

Zapis.Работа = lstZapis(3).List(i)

Zapis.Дата_сдачи = lstZapis(4).List(i)

Zapis.Оценка = lstZapis(5).List(i)

Zapis.Дата_выдачи = lstZapis(6).List(i)

Put #1, i + 1, Zapis

Close #1

Else

strФильтр = "Файлы " + strName + " (*." + strРасширение + ")|*." + strРасширение + "|"

cdl1.Filter = strФильтр

cdl1.Action = 2

If cdl1.FileName <> "" Then

OpenFile = cdl1.FileName

If Dir(OpenFile) = Right$(OpenFile, Len(OpenFile) - Len(ОтрезИмя(OpenFile))) Then

If MsgBox("Файл уже существует. Перезаписать?", vbQuestion + vbYesNo, strName) = vbNo Then Exit Sub

End If

Open OpenFile For Random As 1 Len = Len(Zapis)

For i = 0 To lstZapis(1).ListCount - 1

Zapis.Студент = lstZapis(0).List(i)

Zapis.Группа = lstZapis(1).List(i)

Zapis.Курс = lstZapis(2).List(i)

Zapis.Работа = lstZapis(3).List(i)

Zapis.Дата_сдачи = lstZapis(4).List(i)

Zapis.Оценка = lstZapis(5).List(i)

Zapis.Дата_выдачи = lstZapis(6).List(i)

Put #1, i + 1, Zapis

Close #1

End If

If OpenFile <> "" Then Me.Caption = strName + " - " + OpenFile

End Sub

Public Function ОтрезИмя(Путь As String) As String

Dim b As String

j = 1

Do While Left$(Right$(Путь, j), 1) <> "\"

j = j + 1

Loop

ОтрезИмя = Left$(Путь, Len(Путь) - j + 1)

'n = n + 1

End Function

frmDiagramms

Dim lngAll As Long

Dim lngPoKursu As Long

Dim intGroops As Integer

Private Sub cboОценка_Click()

Dim k As Integer

lstKol.Clear

picStolb.Cls

'Подсчет количества студентов каждой группы, получивших заданную оценку

For i = 0 To lstGroops.ListCount - 1

k = 0

For j = 0 To frmDatabase.lstZapis(1).ListCount - 1

If frmDatabase.lstZapis(1).List(j) = lstGroops.List(i) And frmDatabase.lstZapis(5).List(j) = cboОценка.Text Then k = k + 1

lstKol.AddItem k

Call Stolb(lstGroops.ListCount)

End Sub

Private Sub cmdDiags_Click(Index As Integer)

If Index = 0 Then fraRound.Visible = True: fraStolb.Visible = False: fraGraf.Visible = False

If Index = 1 Then fraRound.Visible = False: fraStolb.Visible = True: fraGraf.Visible = False

If Index = 2 Then fraRound.Visible = False: fraStolb.Visible = False: fraGraf.Visible = True

End Sub

Private Sub Form_Load()

Dim bt As Boolean

Dim gr As Integer

Dim k As Integer

intGrad = 90

lstKurs.Clear

lstGroops2.Clear

lstGroops.Clear

For i = 0 To frmDatabase.lstZapis(1).ListCount - 1

bt = True

For j = 0 To lstKurs.ListCount - 1

If lstKurs.List(j) = frmDatabase.lstZapis(2).List(i) Then bt = False

If bt = True Then

lstKurs.AddItem frmDatabase.lstZapis(2).List(i)

bt = False

End If

Me.Icon = frmDatabase.imlButtons.ListImages(8).Picture

lstKurs.AddItem "По всем курсам"

'Заполнение по всем курсам лист-бокса с количеством работ lstKurs2

lstKurs2.Clear

For j = 0 To lstKurs.ListCount - 2

lngPoKursu = 0

For i = 0 To frmDatabase.lstZapis(2).ListCount - 1

If frmDatabase.lstZapis(2).List(i) = lstKurs.List(j) Then lngPoKursu = lngPoKursu + 1

lstKurs2.AddItem lngPoKursu

lstKurs2.AddItem CStr(frmDatabase.lstZapis(0).ListCount)

'Подсчет количества групп

For i = 0 To frmDatabase.lstZapis(0).ListCount - 1

gr = -1

For j = 0 To lstGroops.ListCount - 1

If lstGroops.List(j) = frmDatabase.lstZapis(1).List(i) Then gr = j

If gr = -1 Then lstGroops.AddItem frmDatabase.lstZapis(1).List(i)

'Копирование лист-бокса групп

For i = 0 To lstGroops.ListCount - 1

lstGroops2.AddItem lstGroops.List(i)

'Заполнение количества должников

For i = 0 To lstGroops2.ListCount - 1

k = 0

For j = 0 To frmDatabase.lstZapis(1).ListCount - 1

If frmDatabase.lstZapis(1).List(j) = lstGroops2.List(i) Then

If Date_raz(frmDatabase.lstZapis(4).List(j), frmDatabase.lstZapis(6).List(j)) > 30 Then k = k + 1

End If

lstkol2.AddItem k

Call Graf

End Sub

Public Sub Round(ob_kol As Long, kol1 As Long)

Dim i As Integer

picRound.Scale (-100, 100)-(100, -100)

picRound.FillColor = vbGreen

picRound.Circle (0, 0), 80, , -0.0007, -kol1 * 6.28 / ob_kol, 0.5

picRound.FillColor = vbRed

picRound.Circle (0, 0), 80, , -kol1 * 6.28 / ob_kol, -6.28, 0.5

For i = 0 To 7

picRound.Circle (0, -i), 80, , 3.14, 6.28, 0.5

picRound.Circle (0, -7), 80, , 3.14, 6.28, 0.5

picRound.Line (-80, 0)-(-80, -7)

picRound.Line (80, 0)-(80, -7)

lblPersent.Caption = CStr(Int(kol1 * 100 / ob_kol)) + " %"

End Sub

Private Sub lstGroops_Click()

If lstKol.ListCount <> 0 Then lstKol.ListIndex = lstGroops.ListIndex

End Sub

Private Sub lstGroops_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If lstKol.ListCount <> 0 Then lstKol.ListIndex = lstGroops.ListIndex

End Sub

Private Sub lstGroops2_Click()

If lstkol2.ListCount <> 0 Then lstkol2.ListIndex = lstGroops2.ListIndex

End Sub

Private Sub lstGroops2_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If lstkol2.ListCount <> 0 Then lstkol2.ListIndex = lstGroops2.ListIndex

End Sub

Private Sub lstKol_Click()

If lstGroops.ListCount <> 0 Then lstGroops.ListIndex = lstKol.ListIndex

End Sub

Private Sub lstKol_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If lstGroops.ListCount <> 0 Then lstGroops.ListIndex = lstKol.ListIndex

End Sub

Private Sub lstkol2_Click()

If lstGroops2.ListCount <> 0 Then lstGroops2.ListIndex = lstkol2.ListIndex

End Sub

Private Sub lstkol2_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If lstGroops2.ListCount <> 0 Then lstGroops2.ListIndex = lstkol2.ListIndex

End Sub

Private Sub lstKurs_Click()

If lstKurs2.ListCount <> 0 Then lstKurs2.ListIndex = lstKurs.ListIndex

If lstKurs.Text = "По всем курсам" Then

picRound.Cls

lblPersent.Visible = False

lbl(0).Caption = "По каждому курсу"

lngAll = frmDatabase.lstZapis(1).ListCount

If lstKurs.ListCount > 1 Then Call AllKurs

Else

picRound.Cls

lblPersent.Visible = True

lbl(0).Caption = "От всех работ выбранный курс составляет:"

lngPoKursu = 0

lngAll = frmDatabase.lstZapis(1).ListCount

For i = 0 To frmDatabase.lstZapis(2).ListCount - 1

If frmDatabase.lstZapis(2).List(i) = lstKurs.Text Then lngPoKursu = lngPoKursu + 1

Call Round(lngAll, lngPoKursu)

End If

End Sub

Private Sub lstKurs_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If lstKurs2.ListCount <> 0 Then lstKurs2.ListIndex = lstKurs.ListIndex

End Sub

Public Sub AllKurs()

Dim i As Integer

Dim ob As Integer

Dim current As Single

current = -0.0007

ob = CInt(lstKurs2.List(lstKurs2.ListCount - 1))

picRound.Cls

'Построение диаграммы

picRound.Scale (-100, 100)-(100, -100)

picRound.FillColor = 2

For i = 0 To lstKurs2.ListCount - 2

picRound.FillColor = QBColor(i + 10)

picRound.Circle (0, 20), 80, , current, current - CInt(lstKurs2.List(i)) * 6.28 / ob, 0.5

current = current - CInt(lstKurs2.List(i)) * 6.28 / ob

'Легенда

picRound.Line (-90 + Int(i / 3) * 80, -60 - 15 * (i - Int(i / 3) * 3))-(-100 + Int(i / 3) * 80, -50 - 15 * (i - Int(i / 3) * 3)), QBColor(i + 10), BF

'Надпись легенды

picRound.Print " " + Left(lstKurs.List(i), 3) + " " + CStr(Int((CInt(lstKurs2.List(i)) * 100 / ob))) + "%"

'Оформление диаграммы

For i = 0 To 7

picRound.Circle (0, -i + 20), 80, , 3.14, 6.28, 0.5

End Sub

Public Sub Stolb(Групп As Integer)

Dim intStWidth As Integer 'Ширина 1 столбца

Dim ed As Integer 'picStolb.scaleheight/Максимальное значение - это одна единица графика

Dim max As Integer

Const dw As Byte = 10 'Промежуток между столбцами

intStWidth = Int(picStolb.ScaleWidth / Групп) - dw

max = CInt(lstKol.List(0))

For i = 0 To lstKol.ListCount - 1

If CInt(lstKol.List(i)) > max Then max = CInt(lstKol.List(i))

ed = 0

If max <> 0 Then ed = picStolb.ScaleHeight / max

'9*ed - высота, равная 9 единицам

For i = 0 To Групп - 1

picStolb.Line (0 + i * (intStWidth + dw), picStolb.ScaleHeight)-(intStWidth + i * (intStWidth + dw), picStolb.ScaleHeight - CInt(lstKol.List(i)) * ed), QBColor(i + 10), BF

'Установка надписей с названими групп

For i = 0 To Групп - 1

picStolb.CurrentX = ((intStWidth - Len(lstGroops.List(i))) / 2) + (dw + intStWidth) * i

picStolb.CurrentY = picStolb.ScaleHeight - 25

picStolb.Print lstGroops.List(i)

End Sub

Public Sub Graf()

Dim intX0 As Integer

Dim edx As Integer

Dim edy As Integer

Dim intY0 As Integer

intX0 = lnOX.X1

edx = Int((lnOX.X2 - intX0) / lstGroops2.ListCount) - 10

intY0 = lnOX.Y1: edy = lstkol2.List(0)

If edy = 0 Then

Exit Sub

End If

For i = 0 To lstkol2.ListCount - 1

If CInt(lstkol2.List(i)) > edy Then edy = CInt(lstkol2.List(i))

edy = Int((intY0 - lnOY.Y1) / edy) - 5

'Установка делений по оси у

For i = 1 To lstkol2.ListCount

picGraf.Line (intX0 - 3, intY0 - CInt(lstkol2.List(i - 1)) * edy)-(intX0 + 3, intY0 - CInt(lstkol2.List(i - 1)) * edy)

picGraf.CurrentX = intX0 - 12

picGraf.CurrentY = intY0 - edy * CInt(lstkol2.List(i - 1)) - 5

picGraf.Print lstkol2.List(i - 1)

'Установка делений по оси х

For i = 1 To lstGroops.ListCount

picGraf.Line (intX0 + i * edx, intY0 - 3)-(intX0 + i * edx, intY0 + 3)

picGraf.CurrentX = intX0 + i * edx - Int(Len(lstGroops2.List(i - 1)) / 2)

picGraf.CurrentY = intY0 + 5

picGraf.Print lstGroops2.List(i - 1)

'Установка точек и их соединение

picGraf.DrawWidth = 5

picGraf.PSet (intX0 + edx, intY0 - CInt(lstkol2.List(0)) * edy), vbRed

For i = 2 To lstGroops2.ListCount

picGraf.DrawWidth = 5

picGraf.PSet (intX0 + i * edx, intY0 - CInt(lstkol2.List(i - 1)) * edy), vbRed

picGraf.DrawWidth = 2

picGraf.Line (intX0 + (i - 1) * edx, intY0 - CInt(lstkol2.List(i - 2)) * edy)-(intX0 + i * edx, intY0 - CInt(lstkol2.List(i - 1)) * edy), vbRed

End Sub

frmAbout

Option Explicit

' Reg Key Security Options...

Const READ_CONTROL = &H20000

Const KEY_QUERY_VALUE = &H1

Const KEY_SET_VALUE = &H2

Const KEY_CREATE_SUB_KEY = &H4

Const KEY_ENUMERATE_SUB_KEYS = &H8

Const KEY_NOTIFY = &H10

Const KEY_CREATE_LINK = &H20

Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _

KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _

KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

' Reg Key ROOT Types...

Const HKEY_LOCAL_MACHINE = &H80000002

Const ERROR_SUCCESS = 0

Const REG_SZ = 1 ' Unicode nul terminated string

Const REG_DWORD = 4 ' 32-bit number

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"

Const gREGVALSYSINFOLOC = "MSINFO"

Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"

Const gREGVALSYSINFO = "PATH"

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub cmdSysInfo_Click()

Call StartSysInfo

End Sub

Private Sub cmdOK_Click()

Unload Me

End Sub

Private Sub Form_Load()

Me.Caption = "О программе " + strName

lblDescription.Caption = strDescription

lblDisclaimer.Caption = strDisclaimer

Me.Icon = frmDatabase.imlButtons.ListImages(12).Picture

End Sub

Public Sub StartSysInfo()

On Error GoTo SysInfoErr

Dim rc As Long

Dim SysInfoPath As String

' Try To Get System Info Program Path\Name From Registry...

If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then

' Try To Get System Info Program Path Only From Registry...

ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then

' Validate Existance Of Known 32 Bit File Version

If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then

SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

' Error - File Can Not Be Found...

Else

GoTo SysInfoErr

End If

' Error - Registry Entry Can Not Be Found...

Else

GoTo SysInfoErr

End If

Call Shell(SysInfoPath, vbNormalFocus)

Exit Sub

SysInfoErr:

MsgBox "System Information Is Unavailable At This Time", vbOKOnly

End Sub

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean

Dim i As Long ' Loop Counter

Dim rc As Long ' Return Code

Dim hKey As Long ' Handle To An Open Registry Key

Dim hDepth As Long '

Dim KeyValType As Long ' Data Type Of A Registry Key

Dim tmpVal As String ' Tempory Storage For A Registry Key Value

Dim KeyValSize As Long ' Size Of Registry Key Variable

'------------------------------------------------------------

' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}

'------------------------------------------------------------

rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...

tmpVal = String$(1024, 0) ' Allocate Variable Space

KeyValSize = 1024 ' Mark Variable Size

'------------------------------------------------------------

' Retrieve Registry Key Value...

'------------------------------------------------------------

rc = RegQueryValueEx(hKey, SubKeyRef, 0, _

KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value

If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors

If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String...

tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String

Else ' WinNT Does NOT Null Terminate String...

tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only

End If

'------------------------------------------------------------

' Determine Key Value Type For Conversion...

'------------------------------------------------------------

Select Case KeyValType ' Search Data Types...

Case REG_SZ ' String Registry Key Data Type

KeyVal = tmpVal ' Copy String Value

Case REG_DWORD ' Double Word Registry Key Data Type

For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit

KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.

KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String

End Select

GetKeyValue = True ' Return Success

rc = RegCloseKey(hKey) ' Close Registry Key

Exit Function ' Exit

GetKeyError: ' Cleanup After An Error Has Occured...

KeyVal = "" ' Set Return Val To Empty String

GetKeyValue = False ' Return Failure

rc = RegCloseKey(hKey) ' Close Registry Key

End Function

frmHelp

Private Sub Form_Load()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Main.html")

End Sub

Private Sub imgAbout_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/About.html")

End Sub

Private Sub imgAdd_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Add.html")

End Sub

Private Sub imgDel_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Del.html")

End Sub

Private Sub imgDiags_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Diags.html")

End Sub

Private Sub imgEdt_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Edt.html")

End Sub

Private Sub imgErrors_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Errors.html")

End Sub

Private Sub imgExit_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Exit.html")

End Sub

Private Sub imgMain_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Main.html")

End Sub

Private Sub imgNew_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/New.html")

End Sub

Private Sub imgOpen_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Open.html")

End Sub

Private Sub imgSave_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Save.html")

End Sub

Private Sub imgSearch_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Search.html")

End Sub

Private Sub imgSort_Click()

Browser.Navigate ("file://localhost/" + App.Path + "/Help/Sort.html")

End Sub

modAbout

'----------------------------------------

'Оперативное изменение программы:

'----------------------------------------

'1) Поменять ниже стоящие константы и массив с названиями всех полей. Если полей больше 7, то добавить новые поля на формах

'frmDatabase, frmAdd, frmEdit, а также изменить их обработку (ну там по коду все понятно где надо добавлять)

'если полей меньше 7, то те же действия, но в другую сторону :-)

'2) Поменять иконки в имидж-листе на форме frmDatabase. Они распространяются сразу на всю программу

'----------------------------------------

Option Explicit

Public Const strName = "MyDataBase" 'Название программы. Также поменять в меню: разработать - MyDataBase свойства

Public Const strDescription = "Программа MyDataBase предназначена для работы с базой данных о студентах, выполняющих лабораторные работы." + vbNewLine + "Автор программы Масляев Евгений. Студент 2-ого курса ИТД КФ МГТУ им. Н. Э. Баумана." + vbNewLine + "Дизайнер: Серегин Арсеий. Студент 2-ого курса ФКДиР МГУП. Год создания программы: 2006" 'Краткое описание

Public Const strDisclaimer = "Авторские права на расширения файлов защищены...производителями Microsoft Access :-)" 'Предупреждение

Public Const strРасширение = "mdb" 'Расширение файлов программы

Public Const intВсегоПолей As Integer = 6 'Количество полей одной записи

Public strПоле(intВсегоПолей) As String

Public Sub init()

'Названия всех полей

strПоле(0) = "Студент"

strПоле(1) = "Группа"

strПоле(2) = "Название курса"

strПоле(3) = "Название работы"

strПоле(4) = "Дата сдачи"

strПоле(5) = "Оценка"

strПоле(6) = "Дата выдачи"

'------------------------------------------

For i = 0 To intВсегоПолей

frmDatabase.optPole(i).Caption = strПоле(i)

frmDatabase.Caption = strName

frmDatabase.Icon = frmDatabase.imlButtons.ListImages(12).Picture

End Sub

modData

Option Explicit

Public i As Long

Public j As Long

Public lngNumberOfEdit As Long

Public strSearch As String

Public intPole As Integer

Public OpenFile As String

Public Zapis As DataBase

Public boolDop As Boolean

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

Public Type DataBase

Студент As String * 50

Группа As String * 8

Курс As String * 50

Работа As String * 50

Дата_сдачи As String * 50

Оценка As Byte

Дата_выдачи As String * 50

End Type

Public Function Date_raz(date1 As String, date2 As String) As Long

Dim ldate1 As Long

Dim ldate2 As Long

ldate1 = CLng(Left(date1, 2)) + 30 * CLng(Mid(date1, 4, 2)) + 365 * CLng(Right(date1, 4))

ldate2 = CLng(Left(date2, 2)) + 30 * CLng(Mid(date2, 4, 2)) + 365 * CLng(Right(date2, 4))

Date_raz = ldate1 - ldate2

End Function

modInspect

Option Explicit

Public NumError As String

Public Const numNumeric As String = "Введено нечисловое значение"

Public Const numДробь As String = "Введено дробное значение"

Public Const numUpLim As String = "Введено слишком большое значение"

Public Const numDownLim As String = "Введено слишком маленькое значение"

Public Function Number(str As String, Дробь As Boolean, Limits As Boolean, DownLim As Double, UpLim As Double) As Boolean

Dim i As Byte

Dim c As String * 1

Dim boolДробь As Boolean

boolДробь = False

If Not IsNumeric(str) Then Number = False: NumError = numNumeric: Exit Function

For i = 1 To Len(str)

c = Mid$(str, i, 1)

If c = "," Or c = "." Then boolДробь = True

If boolДробь = True And Дробь = False Then Number = False: NumError = numДробь: Exit Function

If Limits = True Then

If CDbl(str) > UpLim Then Number = False: NumError = numUpLim: Exit Function

If CDbl(str) < DownLim Then NumError = numDownLim: Exit Function

End If

NumError = ""

Number = True

End Function

ПРИЛОЖЕНИЕ 2

Формы программы

frmStart

rmDatabase

frmAdd

frmEdit

frmDiagramms

frmSearch

frmHelp

frmAbout

Страницы: 1, 2