Каталог Рефератов - Создание базы данных - скачать рефераты, бесплатно рефераты

	Информационно-образоательный портал
	Рефераты, курсовые, дипломы, научные работы,



МЕНЮ\|

поиск

Создание базы данных

472End Sub

2473

2474' удаление таблицы *************************************************

2475Public Sub DelTable(Index%)

2476 For i% = Index To (UBound(DB) - 1)

2477 DB(i) = DB(i + 1)

2478 Next i

2479 If (UBound(DB) > 0) Then ReDim Preserve DB(UBound(DB) - 1)

2480End Sub

2481

2482' если нужно то строка шифруется по паролю, иначе не изменяется

2483Function CodeDecode(Index%, str$, col%, row%, Optional pass$ = "", Optional usepass As Boolean = False) As String

2484 If Not usepass Then pass$ = DB(Index). Password

2485 If (pass = "") Then

2486 CodeDecode = str

2487 Exit Function

2488 End If

2489 CodeDecode = ""

2490 p% = 1

2491 Dim ch As Byte

2492 For i% = 1 To Len(str)

2493 ch = Asc(Mid(str, i, 1)) Xor Asc(Mid(pass, p, 1)) Xor col Xor row

2494 CodeDecode = CodeDecode + Chr(ch)

2495 p = p + 1: If p > Len(pass) Then p = 1

2496 Next i

2497End Function

2498

2499' сохранение БД в файле *************************************************

2500Public Sub FlushDB(DBIndex%)

2501 Dim s$, W%

2502 If Not UserIsAdmin Then

2503 Call ProtectedMsg

2504 Exit Sub

2505 End If

2506 If (DBPath <> "") Then

2507 Call DeleteFile(DBPath)

2508 DBI% = FreeFile

2509 Open DBPath For Binary As DBI

2510

2511 ' заголовок - 12

2512 Put DBI,, DB(DBIndex). Header

2513

2514 ' если надо, то сохраняю пароль

2515 If (DB(DBIndex). Header. Flags And flPasswordNeed) Then

2516 Dim str$, ch1 As Byte, ch2 As Byte

2517 Dim lng As Byte, lng2 As Byte

2518 lng = Len(DB(DBIndex). Password)

2519 lng2 = lng / 2

2520 Put DBI,, lng

2521

2522 For i% = 1 To lng2

2523 ch1 = Asc(Mid(DB(DBIndex). Password, i, 1))

2524 ch2 = Asc(Mid(DB(DBIndex). Password, lng - i + 1, 1))

2525 str = Chr(ch1 Xor ch2) + str

2526 Next i

2527 For i = lng2 To 1 Step - 1

2528 Put DBI,, CByte(Asc(Mid(str, i, 1)))

2529 Next i

2530 End If ' сохранение пароля

2531

2532 ' данные полей

2533 Dim l As Long

2534 For i% = 0 To DB(DBIndex). Header. ColCount - 1

2535 Put DBI,, DB(DBIndex). Cols(i). Class

2536 Put DBI,, DB(DBIndex). Cols(i). TitleLen

2537 If (DB(Index). Header. Flags And flCoded) Then

2538 Put DBI,, CodeDecode(DBIndex, DB(DBIndex). Cols(i). title, i, 0)

2539 Else

2540 Put DBI,, DB(DBIndex). Cols(i). title

2541 End If

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

2543 Case ccString

2544 If (DB(Index). Header. Flags And flCoded) Then

2545 s = CodeDecode(DBIndex, CStr(DB(DBIndex). Cols(i). DefValue), i, 0)

2546 Else

2547 s = CStr(DB(DBIndex). Cols(i). DefValue)

2548 End If

2549 W = Len(s)

2550 Put DBI,, W

2551 Put DBI,, s

2552 Case ccInteger

2553 l = CInt(DB(DBIndex). Cols(i). DefValue)

2554 Put DBI,, l

2555 End Select

2556 Next i

2557

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

2559 Put DBI,, ValidateByte

2560

2561 ' записи

2562 Dim f As TDBElem

2563 Dim col As TDBElemData

2564 For R% = 0 To DB(DBIndex). Header. RowCount - 1

2565 f = DB(DBIndex). Rows(R)

2566 For c% = 0 To DB(DBIndex). Header. ColCount - 1

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

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

2569 Select Case col. Class

2570 ' если число - записываю как long

2571 Case ccInteger

2572 l = CLng(f. Fields(c))

2573 Put DBI,, l

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

2575 Case ccString

2576 If (DB(Index). Header. Flags And flCoded) Then

2577 s = CodeDecode(DBIndex, CStr(f. Fields(c)), c, R)

2578 Else

2579 s = CStr(f. Fields(c))

2580 End If

2581 ' Len возвращает 4 байта, а мне нужно 2

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

2851

2852' перетаскивание

2853Dim ClickBool As Boolean

2854Dim Xs%, Ys%

2855

2856Sub MInit()

2857 ClickBool = False

2858 Xs = 0

2859 Ys = 0

2860End Sub

2861

2862Sub MMove(ByVal Handle As Long, ByVal x%, ByVal y%)

2863 Dim R As RECT

2864 If ClickBool Then

2865 Call GetWindowRect(Handle, R)

2866 W% = R. Right - R. Left

2867 H% = R. Bottom - R. Top

2868 x = R. Left + (x - Xs) / Screen. TwipsPerPixelX

2869 y = R. Top + (y - Ys) / Screen. TwipsPerPixelY

2870 Call MoveWindow(Handle, x, y, W, H, True)

2871 End If

2872End Sub

2873

2874Sub MDown(ByVal x%, ByVal y%)

2875 ClickBool = True

2876 Xs = x

2877 Ys = y

2878End Sub

2879

2880Sub MUp()

2881 ClickBool = False

2882End Sub

Модуль: DBConst. bas

2883' результаты работы диалогов из MsgBox

2884Public Const resBad = 0 ' выход, закрытием окна

2885Public Const resOk = 1 ' Да

2886Public Const resNo = 2 ' Нет

2887Public Const resCancel = 3 ' Отмена

2888

2889' константы типов данных

2890Public Const ccInteger As Byte = 0

2891Public Const ccString As Byte = 1

2892

2893' флаги доступа доступа к БД

2894 ' требовать пароль для входа

2895Public Const flPasswordNeed As Byte = 1

2896 ' запрещать доступ на чтение без пароля

2897Public Const flReadOnlyEnable As Byte = 2

2898 ' зашифрованность данных

2899Public Const flCoded As Byte = 4

2900

2901' для диаграмм

2902Type TDiagElem

2903 Text As String

2904 Val As Integer

2905 Color As Long

2906End Type

2907

2908' права Только чтение

2909Public Sub ProtectedMsg()

2910 Call MsgForm. ErrorMsg("Недостаточно прав для выполнения действия! ")

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11

© 2003-2013
Рефераты бесплатно, курсовые, рефераты биология, большая бибилиотека рефератов, дипломы, научные работы, рефераты право, рефераты, рефераты скачать, рефераты литература, курсовые работы, реферат, доклады, рефераты медицина, рефераты на тему, сочинения, реферат бесплатно, рефераты авиация, рефераты психология, рефераты математика, рефераты кулинария, рефераты логистика, рефераты анатомия, рефераты маркетинг, рефераты релиния, рефераты социология, рефераты менеджемент.