49028 (Создание базы данных о студентах ВУЗа), страница 6

2016-07-30СтудИзба

Описание файла

Документ из архива "Создание базы данных о студентах ВУЗа", который расположен в категории "". Всё это находится в предмете "информатика" из 1 семестр, которые можно найти в файловом архиве . Не смотря на прямую связь этого архива с , его также можно найти и в других разделах. Архив можно найти в разделе "курсовые/домашние работы", в предмете "информатика, программирование" в общих файлах.

Онлайн просмотр документа "49028"

Текст 6 страницы из документа "49028"

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

frmSearch

frmHelp

frmAbout

Свежие статьи
Популярно сейчас
Зачем заказывать выполнение своего задания, если оно уже было выполнено много много раз? Его можно просто купить или даже скачать бесплатно на СтудИзбе. Найдите нужный учебный материал у нас!
Ответы на популярные вопросы
Да! Наши авторы собирают и выкладывают те работы, которые сдаются в Вашем учебном заведении ежегодно и уже проверены преподавателями.
Да! У нас любой человек может выложить любую учебную работу и зарабатывать на её продажах! Но каждый учебный материал публикуется только после тщательной проверки администрацией.
Вернём деньги! А если быть более точными, то автору даётся немного времени на исправление, а если не исправит или выйдет время, то вернём деньги в полном объёме!
Нет! Мы не выполняем работы на заказ, однако Вы можете попросить что-то выложить в наших социальных сетях.
Добавляйте материалы
и зарабатывайте!
Продажи идут автоматически
4121
Авторов
на СтудИзбе
667
Средний доход
с одного платного файла
Обучение Подробнее