Курсовая работа: Создание базы данных

2582 W = Len(s)

2583 Put DBI,, W

2584 Put DBI,, s

2585 End Select

2586 Next c

2587 Next R

2588

2589 MainForm. SB. Panels(3). Text = DBPath

2590 Call MsgForm. InfoMsg("БД сохранена! ")

2591

2592 ' закрытие файла

2593 Close

2594 DBChanged = False

2595 Call TestDBChanged

2596 End If

2597End Sub

2598

2599' загрузка БД *************************************************

2600Public Function LoadDB(DBIndex%, ByVal Path$) As Boolean

2601 Dim DBH As TDBHeader

2602 pwrd$ = ""

2603 LoadDB = False

2604 DBI% = FreeFile

2605 DBP$ = Path

2606 ' открываю БД

2607 Open DBP For Binary As DBI

2608 ' считываю заголовок

2609 Get DBI,, DBH

2610 With DBH

2611 If (. Header <> "DBX") Then

2612 Call MsgForm. ErrorMsg("БД повреждена! ")

2613 GoTo Notdata

2614 End If

2615

2616 ' если надо, то загружаю пароль

2617 If (DBH. Flags And flPasswordNeed) Then

2618 Dim lng As Byte

2619 Get DBI,, lng

2620 Dim str$, ch1 As Byte, ch2 As Byte, ch3 As Byte

2621 str = ""

2622 For i% = 1 To lng \ 2

2623 Get DBI,, ch1

2624 str = str + Chr(ch1)

2625 Next i

2626'********************************************************

2627 With PasswordForm

2628. PassText = ""

2629

2630. CaptionLabel = "Защита БД"

2631. TextLabel = "Открываемая БД защищена паролем. Для работы с БД необходимо ввести пароль. "

2632. Frame2. Visible = False

2633. Frame1. Visible = True

2634

2635 Dim ROE As Boolean

2636

2637 ROE = Not ((DBH. Flags And flReadOnlyEnable) = flReadOnlyEnable)

2638

2639 If ROE Then

2640. Frame3. Visible = True

2641. NoFullLabel. Visible = False

2642 Else

2643. Frame3. Visible = False

2644. NoFullLabel. Visible = True

2645 End If

2646. Show vbModal

2647 If (. res) Then

2648 ' допустимый тип доступа

2649 Mode% = 0

2650 ' введёный пароль

2651 str2$ = Trim(. PassText)

2652

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

2654 lng_2 = Len(str2)

2655 If (lng_2 <> lng) Then

2656 Mode = - 1

2657 GoTo bad

2658 End If

2659 For i% = 1 To lng \ 2

2660 ch1 = Asc(Mid(str2, i, 1))

2661 ch2 = Asc(Mid(str2, lng - i + 1, 1))

2662 ch3 = Asc(Mid(str, i, 1))

2663 If ((ch1 Xor ch2) <> ch3) Then

2664 Mode = - 1

2665 GoTo bad

2666 End If

2667 Next i

2668

2669bad:

2670 ' обработка правильности пароля и уровня доступа

2671 If (Mode = 0) And (. Check1 = 0) Then

2672 Call MsgForm. InfoMsg("Пароль принят! ")

2673 pwrd = str2

2674 UserIsAdmin = True

2675 Else

2676 If ROE And (. Check1 = 1) Then

2677 Call MsgForm. InfoMsg("Только чтение! ")

2678 UserIsAdmin = False

2679 Else

2680 Call MsgForm. ErrorMsg("Пароль не принят! Доступ запрещён! ")

2681 Unload PasswordForm

2682 GoTo Notdata

2683 End If

2684 End If

2685 Else

2686 Unload PasswordForm

2687 GoTo Notdata

2688 End If ' if (. res)

2689 Unload PasswordForm

2690 End With

2691'********************************************************

2692 End If

2693

2694 ' выделение нужной памяти

2695 If (. ColCount > 0) Then

2696 ReDim DB(DBIndex). Cols(. ColCount - 1)

2697 If (. RowCount > 0) Then

2698 ReDim DB(DBIndex). Rows(. RowCount - 1)

2699 For R% = 0 To. RowCount - 1

2700 ReDim DB(DBIndex). Rows(R). Fields(. ColCount - 1)

2701 Next R

2702 End If

2703 End If

2704

2705 ' считывание данных полей

2706 For i% = 0 To DBH. ColCount - 1

2707 ' получение класса

2708 Get DBI,, DB(DBIndex). Cols(i). Class

2709 ' получение длины заголовка

2710 Get DBI,, DB(DBIndex). Cols(i). TitleLen

2711 ' получение заголовка

2712 s$ = ""

2713 Dim B As Byte

2714 For j% = 1 To DB(DBIndex). Cols(i). TitleLen

2715 Get DBI,, B

2716 s = s + Chr(B)

2717 Next j

2718 s = CodeDecode(DBIndex, s, i, 0, pwrd, True)

2719 DB(DBIndex). Cols(i). title = s

2720 ' получение значения по-умолчанию

2721 Dim l As Long

2722 Dim W%

2723 Select Case DB(DBIndex). Cols(i). Class

2724 Case ccInteger

2725 Get DBI,, l

2726 DB(DBIndex). Cols(i). DefValue = l

2727 Case ccString

2728 Get DBI,, W

2729 s = ""

2730 For j% = 1 To W

2731 Get DBI,, B

2732 s = s + Chr(B)

2733 Next j

2734 s = CodeDecode(DBIndex, s, i, 0, pwrd, True)

2735 DB(DBIndex). Cols(i). DefValue = s

2736 End Select

2737 Next i

2738

2739 ' чтение контрольного байта

2740 Dim VB As Byte

2741 Get DBI,, VB

2742 If (VB <> ValidateByte) Then

2743 Call MsgForm. ErrorMsg("БД повреждена! ")

2744 GoTo Notdata

2745 End If

2746

2747 ' считывание записей

2748 Dim col As TDBElemData

2749 For R% = 0 To. RowCount - 1

2750 For c% = 0 To. ColCount - 1

2751 col = DB(DBIndex). Cols(c)

2752 ' в зависимости от типа данных колонки пишу в файл определённый тип данных

2753 Select Case col. Class

2754 ' если число - считываю как long

2755 Case ccInteger

2756 Get DBI,, l

2757 DB(DBIndex). Rows(R). Fields(c) = l

2758 ' если строка - то байт длины и сама строка

2759 Case ccString

2760 Get DBI,, W

2761 s = ""

2762 For j% = 1 To W

2763 Get DBI,, B

2764 s = s + Chr(B)

2765 Next j

2766 s = CodeDecode(DBIndex, s, c, R, pwrd, True)

2767 DB(DBIndex). Rows(R). Fields(c) = s

2768 End Select

2769 Next c

2770 Next R

2771

2772 End With

2773 LoadDB = True

2774

2775 DB(DBIndex). Header = DBH

2776 DBPath = DBP

2777 DBChanged = False

2778 DB(DBIndex). Password = pwrd

2779

2780 Call MsgForm. InfoMsg("БД загружена! ")

2781

2782Notdata:

2783 ' закрытие файла

2784 Close

2785End Function

2786

2787' создание новой БД *************************************************

2788Public Function NewDB(Path$)

2789 DBI% = FreeFile

2790 ' удаляю БД

2791 Call DeleteFile(Path)

2792 ' открываю БД

2793 Open Path For Binary As DBI

2794 ' применяю стандартный заголовок к БД

2795 Call ClearAll

2796 DBPath = Path

2797 ' записываю заголовок БД

2798 Put DBI,, DB(0). Header

2799 ' запись контрольного байта

2800 Put DBI,, ValidateByte

2801 Close

2802 Call MsgForm. InfoMsg("БД создана с настройками по-умолчанию! ")

2803End Function

2804

2805' очистка ВСЕГО

2806Public Sub ClearAll()

2807 ReDim DB(0)

2808 Call ClearHeader(DB(0). Header)

2809 DBChanged = False

2810 DBPath = ""

2811End Sub

2812

2813' установка полей в начальные значения *************************************************

2814Public Sub ClearHeader(H As TDBHeader)

2815 H. Header = "DBX"

2816 H. Flags = 0

2817 H. ColCount = 0

2818 H. RowCount = 0

2819End Sub

Модуль: API. bas

2820' создание файла

2821Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

2822

2823' создание архивной копии БД

2824Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

2825

2826' запуск браузера и почтовой программы

2827Public Declare Function ShellExecute Lib "shell32. dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

2828

2829' звук

2830Public Declare Function sndPlaySound Lib "winmm. dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

2831Public Const SND_APPLICATION = &H80

2832Public Const SND_ASYNC = &H1

2833Public Const SND_FILENAME = &H20000

2834

2835' перемещение окна и анимация кнопок

2836Public Type RECT

2837 Left As Long

2838 Top As Long

2839 Right As Long

2840 Bottom As Long

2841End Type

2842Public Type POINTAPI

2843 x As Long

2844 y As Long

2845End Type

2846Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

2847Public Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

2848Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

2849Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

2850Public Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20