Информация о программе
При переходе по меню "Справка -> О программе" (Рис.13)
Рис.13
Вы получаете доступ к форме "О программе MyDataBase" (Приложение 2. с.65). На ней кратко описана цель проекта, фамилия разработчика и об авторских правах.
Сообщения программы 1. Не задано поле для поиска.
Это означает, что вы обратились к поиску по первой букве, но не выделили поле. Поиск по первой букве не может быть осуществлен при не выбранном поле. Выбрать его можно, щелкнув по заголовку поля. При этом заголовок поля примет вид нажатой кнопки. Чтобы снять выделение поля, щелкните мышью на свободном месте главной формы. Заголовок вернется в нормальное состояние. Искать данные по первой букве можно только тогда, когда выделено одно из полей. 2. Введено нечисловое, дробное, слишком большое или слишком маленькое значение.
При добавлении или изменении записи может возникнуть эта ошибка. Она означает, что в поле "Оценка" введено не число. Оценка - это натуральное число в диапозоне от 0 (студент не явился) до 5 (отлично). Если оценка введена больше 5, то возникнет ошибка:
Границы ввода определяются контролем ввода. Правила ввода вы можете посмотреть на примере формы добавления записи. 3. Дата выдачи больше даты сдачи.
При добавлении или редактировании записей таблицы вы не можете указать дату выдачи работы более позднюю, чем дату сдачи. Студенты редко сдают работы раньше получения заданий.
ЛИТЕРАТУРА
1. С.В. Глушаков А.С. Сурядный программирование на VB6.0 «Фолио» 2002г. 2. С.И. Воронцов Microsoft Visual Basic 5.0 «Солон» 1998г.
ПРИЛОЖЕНИЕ 1 Код программы frmStart
Dim x As Byte
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 27 Then Call Terminate End Sub
Private Sub Form_Load() x = 0 End Sub
Private Sub tmrAni_Timer() If x <= 18 Then imgAnim.Picture = img(x).Picture x = x + 1 If x = 40 Then Me.Picture = img(19).Picture: imgAnim.Visible = False If x = 60 Then Call Terminate End Sub
Public Sub Terminate() tmrAni.Enabled = False frmDatabase.Show Unload Me End Sub
frmDatabase
Option Explicit Public Sub Create() If MsgBox("Несохраненные данные будут потеряны. Создать новую базу?", vbQuestion + vbYesNo, strName) = vbNo Then Exit Sub For i = 0 To 6 lstZapis(i).Clear Next OpenFile = "" Me.Caption = strName End Sub
Public Sub Open_File() Dim strФильтр As String If MsgBox("Несохраненные данные будут потеряны. Открыть файл?", vbQuestion + vbYesNo, strName) = vbNo Then Exit Sub For i = 0 To 6 lstZapis(i).Clear Next OpenFile = ""
strФильтр = "Файлы " + strName + " (*." + strРасширение + ")|*." + strРасширение + "|" cdl1.Filter = strФильтр cdl1.Action = 1 If cdl1.FileName <> "" Then OpenFile = cdl1.FileName Open OpenFile For Random As 1 Len = Len(Zapis) For i = 1 To FileLen(OpenFile) / Len(Zapis) Get #1, i, Zapis lstZapis(0).AddItem Trim(Zapis.Студент) lstZapis(1).AddItem Trim(Zapis.Группа) lstZapis(2).AddItem Trim(Zapis.Курс) lstZapis(3).AddItem Trim(Zapis.Работа) lstZapis(4).AddItem Trim(Zapis.Дата_сдачи) lstZapis(5).AddItem Trim(Zapis.Оценка) lstZapis(6).AddItem Trim(Zapis.Дата_выдачи) Next Close #1 End If If 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 Next 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 Next Close #1 End If 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) Next 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 Next strЗапрос = "" intPole = -1 If strType = "Fst" Then strSearch = InputBox("Введите первую букву записи выделенного поля (регистр не учитывается)", "Поиск по первой букве", "а") For i = 0 To 6 If optPole(i).Value = True Then intPole = i Next 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) Next frmSearch.lstNumbers.AddItem i End If Next 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 End If Next Next 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 If Next Next 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 Next End If
If strType = "Color" Then cdl1.Action = 3 For i = 0 To 6 lstZapis(i).ForeColor = cdl1.Color Next 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) Next End If
If Index = 11 Then For i = 0 To 6 If optPole(i).Value = True Then Call Sort("Dwn", i) Next End If
If Index = 9 Then If Quite = True Then End End If
For i = 0 To 11 cmdTool(i).Default = False Next 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 Next 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 Next 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 Next 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) Next 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 Next 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)) Next
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) Next frmSearch.lstNumbers.AddItem i End If Next 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 Next 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) Next frmSearch.lstNumbers.AddItem i End If Next frmSearch.Show 1 End Sub
Private Sub mnuUp_Click() For i = 0 To 6 If optPole(i).Value = True Then Call Sort("Up", i) Next End Sub
Private Sub mnuZap1_Click() Dim strStud As String strStud = lstZapis(0).Text For i = 0 To 6 frmSearch.lstZapis(i).Clear Next 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) Next frmSearch.lstNumbers.AddItem i End If Next 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 Next 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) Next frmSearch.lstNumbers.AddItem i End If End If Next 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 Next 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) Next 'Проверка дат на совпадение 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 Next Next 'Если больше 2-х одинаковых, вносим в результат If k > 2 Then For n = 0 To 6 frmSearch.lstZapis(n).AddItem lstZapis(n).List(i) Next frmSearch.lstNumbers.AddItem i End If Next 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 Next 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) Next frmSearch.lstNumbers.AddItem i End If Next 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 Next
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 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) Next 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) Next 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) Next 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 Next 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 Next 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 Next 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 Next 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 Next Close #1 End If 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 Next lstKol.AddItem k Next 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 Next If bt = True Then lstKurs.AddItem frmDatabase.lstZapis(2).List(i) bt = False End If Next 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 Next lstKurs2.AddItem lngPoKursu Next 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 Next If gr = -1 Then lstGroops.AddItem frmDatabase.lstZapis(1).List(i) Next 'Копирование лист-бокса групп For i = 0 To lstGroops.ListCount - 1 lstGroops2.AddItem lstGroops.List(i) Next 'Заполнение количества должников 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 Next lstkol2.AddItem k Next 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 Next 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 Next 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))) + "%" Next
'Оформление диаграммы For i = 0 To 7 picRound.Circle (0, -i + 20), 80, , 3.14, 6.28, 0.5 Next 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)) Next 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 Next 'Установка надписей с названими групп 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) Next 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)) Next 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) Next 'Установка делений по оси х 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) Next 'Установка точек и их соединение 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 Next 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. Next 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) Next 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 Next 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
2019-07-03 |
171 |
Обсуждений (0) |
|
5.00
из
|
|
Обсуждение в статье: Информация о программе |
Обсуждений еще не было, будьте первым... ↓↓↓ |
Почему 1285321 студент выбрали МегаОбучалку...
Система поиска информации
Мобильная версия сайта
Удобная навигация
Нет шокирующей рекламы