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 DimcolAsTDBElemData
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 = ""
2811EndSub
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
2918Public Function IsInteger(ByVal str$) As Boolean
2919 Dim Arr(1 To 4) As String * 1
2920 Arr(1) = "e": Arr(2) = "E": Arr(3) = ",": Arr(4) = ". "
2921 IsInteger = True
2922 If IsNumeric(str) Then
2923 For i% = LBound(Arr) To UBound(Arr)
2924 If (InStr(1, str, Arr(i)) > 0) Then
2925 IsInteger = False
2926 Exit For
2927 End If
2928 Next i
2929 Else
2930 IsInteger = False
2931 End If
2932End Function
2933
2934Public Sub ButEnabled(Pict As Image, Lbl As Label, enbl As Boolean)
2935 If enbl Then
2936 Pict. Picture = MainForm. ButtonImageList. ListImages(1). Picture
2937 Lbl. MousePointer = 1
2938 Else
2939 Pict. Picture = MainForm. ButtonImageList. ListImages(2). Picture
2940 Lbl. MousePointer = 12
2941 End If
2942 Lbl. Tag = CInt(enbl)
2943End Sub
Модуль: QueryRunner. bas
2944Public QRDBIndex%
2945
2946'***********************************
2947' Запросы чувствительны к регистру!
2948'***********************************
2949
2950' константы видов запросов
2951 ' ОБЯЗАТЕЛЬНО 3 ЗНАКА
2952Public Const sAdd$ = "Add"
2953Public Const sDel$ = "Del"
2954Public Const sSort$ = "Srt"
2955Public Const sOut$ = "Out"
2956Public Const sSwap$ = "Swp"
2957Public Const sChange$ = "Chg"
2958
2959' константы подтипов запросов
2960Public Const sCol$ = "Col"
2961PublicConstsRow$ = "Row"
2962PublicConstsTable$ = "Tbl" ' только для использования в запросе Вывод
2963Public Const sAZ$ = "AZ"
2964Public Const sZA$ = "ZA"
2965Public Const sEqual$ = "? ="
2966Public Const sAbove$ = "? >"
2967Public Const sBelow$ = "? <"
2968Public Const sCountEqual$ = "+="
2969Public Const sCountAbove$ = "+>"
2970Public Const sCountBelow$ = "+<"
2971Public Const sI$ = "i"
2972Public Const sS$ = "s"
2973Public Const sYes$ = "yes"
2974Public Const sNo$ = "no"
2975Public Const sType$ = "Type"
2976Public Const sName$ = "Name"
2977
2978' остальныеконстанты
2979Public Const sSep$ = "; "
2980
2981'************************ Формирует строку добавления 'What' ************************
2982Public Function Generate_Add(ByVal what$) As String
2983 If (what = sCol) Then
2984 s$ = AddColForm. AddColDlg(QRDBIndex)
2985 If (s <> "") Then
2986 Generate_Add = sAdd + sCol + "(" + s + ")"
2987 Else
2988 Generate_Add = ""
2989 End If
2990 Else
2991 Generate_Add = sAdd + sRow + "()"
2992 End If
2993End Function
2994
2995'************************ Формирует строку удаления 'What' ************************
2996Public Function Generate_Del(ByVal what$) As String
2997 With SelectForm. CheckConfirm
2998. value = 1
2999. Visible = True
3000 End With
3001 Dim conf$
3002
3003 If (what = sCol) Then
3004 s$ = SelectForm. SelectDlg(QRDBIndex, "Выберитеудаляемоеполе", sCol)
3005 If (s <> - 1) Then
3006 If (SelectForm. CheckConfirm. value = 1) Then
3007 conf = sYes
3008 Else
3009 conf = sNo
3010 End If
3011 Generate_Del = sDel + sCol + "(" + s + ", " + conf + ")"
3012 Else
3013 Generate_Del = ""
3014 End If
3015 Else
3016 s$ = SelectForm. SelectDlg(QRDBIndex, "Выберитеудаляемуюзапись", sRow)
3017 If (s <> - 1) Then
3018 If (SelectForm. CheckConfirm. value = 1) Then
3019 conf = sYes
3020 Else
3021 conf = sNo
3022 End If
3023 Generate_Del = sDel + sRow + "(" + s + ", " + conf + ")"
3024 Else
3025 Generate_Del = ""
3026 End If
3027 End If
3028End Function
3029
3030'************************ Формирует строку сортировки по 'What' ************************
3031Public Function Generate_Sort(ByVal what$) As String
3032 SelectForm. CheckConfirm. Visible = False
3033
3034 s$ = SelectForm. SelectDlg(QRDBIndex, "Выберите поле сортировки", sCol)
3035 If (s <> - 1) Then
3036 Generate_Sort = sSort + "(" + s + ", " + what + ")"
3037 Else
3038 Generate_Sort = ""
3039 End If
3040End Function
3041
3042'************************ Формирует строку вывода по 'What' ************************
3043Public Function Generate_Out(ByVal what$) As String
3044 Generate_Out = ""
3045 SelectForm. CheckConfirm. Visible = False
3046 Dim str$
3047
3048 s$ = SelectForm. SelectDlg(QRDBIndex, "Выберитеполе", sCol)
3049 If (s <> "-1") Then
3050 str = Trim(InputForm. InputVal("Введите относительное значение"))
3051 If (str <> "") Then
3052 Dim CreateNewTab As Boolean
3053 CreateNewTab = (MsgForm. QuestMsg("Выводить в новую таблицу? Нет для вывода в уже существующую. ") = resOk)
3054 If (Not CreateNewTab) Then
3055 Table$ = SelectForm. SelectDlg(QRDBIndex, "Выберитетаблицу", sTable)
3056 If (Table = "-1") Then Exit Function
3057 Generate_Out = sOut + "(" + s + ", " + what + str + ", " + Table + ")"
3058 Else
3059 Generate_Out = sOut + "(" + s + ", " + what + str + ")"
3060 End If
3061 Else
3062 Call MsgForm. ErrorMsg("Не задано относительное значение! ")
3063 End If
3064 End If
3065End Function
3066
3067'************************ Формирует строку обмена по 'What' ************************
3068Public Function Generate_Swap(ByVal what$) As String
3069 If (what = sCol) Then
3070 s$ = SelectForm. MultiSelectDlg(QRDBIndex, "Выберите 2 обмениваемыхполя", sCol)
3071 If (s <> "") Then
3072 p% = InStr(1, s, ",")
3073 Generate_Swap = sSwap + sCol + "(" + Left(s, p - 1) + ", " + Mid(s, p + 1) + ")"
3074 Else
3075 Generate_Swap = ""
3076 End If
3077 Else
3078 s$ = SelectForm. MultiSelectDlg(QRDBIndex, "Выберите 2 обмениваемыезаписи", sRow)
3079 If (s <> "") Then
3080 p% = InStr(1, s, ",")
3081 Generate_Swap = sSwap + sRow + "(" + Left(s, p - 1) + ", " + Mid(s, p + 1) + ")"
3082 Else
3083 Generate_Swap = ""
3084 End If
3085 End If
3086End Function
3087
3088'************************ Формирует строку изменения 'What' ************************
3089Public Function Generate_Change(ByVal what$) As String
3090 Generate_Change = ""
3091 SelectForm. CheckConfirm. Visible = False
3092
3093 s$ = SelectForm. SelectDlg(QRDBIndex, "Выберитеизменяемоеполе", sCol)
3094 If (s = "-1") Then Exit Function
3095 Select Case what
3096 Case sType ' Изменение типа поля
3097 Generate_Change = sChange + sType + "(" + s + ")"
3098 Case sName ' Изменение названия столбца
3099 Name$ = InputForm. InputVal("Введите новое название поля")
3100 If (Name = "") Then Exit Function
3101 Generate_Change = sChange + sName + "(" + s + ", " + Name + ")"
3102 End Select
3103End Function
3104
3105Sub ErrorInQuery()
3106 Call MsgForm. ErrorMsg("Ошибкавзапросе! ")