50133 (609948), страница 10
Текст из файла (страница 10)
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("Недостаточно прав для выполнения действия! ")
2911End Sub
2912
2913' звук нажатия кнопки
2914Public Sub SoundClick()
2915 Call sndPlaySound("Data\Click. wav", SND_ASYNC + SND_FILENAME + SND_LOOP + SND_APPLICATION)
2916End Sub
2917
