50133 (Создание базы данных), страница 11

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"

2961Public Const sRow$ = "Row"

2962Public Const sTable$ = "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("Ошибка в запросе! ")

3107End Sub

3108

3109Function TestZero(i%)

3110 If (i = 0) Then

3111 Call ErrorInQuery

3112 TestZero = True

3113 Else

3114 TestZero = False

3115 End If

3116End Function

3117

3118Sub AddRun(what$, str$)

3119 Select Case what

3120 Case sCol

3121 ' заголовок

3122 p% = InStr(1, str, ",")

3123 If TestZero(p) Then Exit Sub

3124 title$ = Trim(Left(str, p - 1))

3125 str = Mid(str, p + 1)

3126 ' тип

3127 p = InStr(1, str, ",")

3128 If TestZero(p) Then Exit Sub

3129 ColType$ = Trim(Left(str, p - 1))

3130 str = Mid(str, p + 1)

3131

3132 ' начальное значение

3133 p = InStr(1, str, ",")

3134 If TestZero(p) Then Exit Sub

3135 StValStr$ = Trim(Left(str, p - 1))

3136 str = Mid(str, p + 1)

3137

3138 ' позиция

3139 ColPosStr$ = str

3140 If (Not IsNumeric(ColPosStr)) Then

3141 Call ErrorInQuery

3142 Exit Sub

3143 End If

3144 ColPos% = CInt(ColPosStr)

3145

3146 If ItColAlreadyCreate(QRDBIndex, title) Then

3147 Call MsgForm. ErrorMsg("Добавляемое поле уже существует! ")

3148 Exit Sub

3149 End If

3150

3151 ' в зависимости от типа определяю значение

3152 Select Case ColType

3153 Case sI

3154 If (Not IsInteger(StValStr)) Then

3155 Call ErrorInQuery

3156 Exit Sub

3157 End If

3158 stval = CInt(StValStr)

3159 Call AddCol(QRDBIndex, ccInteger, title, stval, ColPos)

3160 Case sS

3161 stval = CStr(StValStr)

3162 Call AddCol(QRDBIndex, ccString, title, stval, ColPos)

3163 Case Default

3164 Call ErrorInQuery

3165 Exit Sub

3166 End Select

3167

3168 Case sRow

3169 If (DB(QRDBIndex). Header. ColCount > 0) Then

3170 Dim row() As Variant

3171 ReDim row(DB(QRDBIndex). Header. ColCount - 1)

3172 For i = 0 To DB(QRDBIndex). Header. ColCount - 1

3173 row(i) = DB(QRDBIndex). Cols(i). DefValue

3174 Next i

3175 If (Not FindRow(QRDBIndex, row)) Then

3176 Call AddField(QRDBIndex, row)

3177 Else

3178 Call MsgForm. ErrorMsg("Добавляемый столбец дублируется! ")

3179 End If

3180 Else

3181 Call MsgForm. ErrorMsg("Нельзя добавлять записи в БД без полей! ")

3182 End If

3183 End Select

3184

3185End Sub

3186

3187Sub DelRun(what$, str$)

3188 p% = InStr(1, str, ",")

3189 If TestZero(p) Then Exit Sub

3190 IndexStr$ = Trim(Left(str, p - 1))

3191 If (Not IsInteger(IndexStr)) Then

3192 Call ErrorInQuery

3193 Exit Sub

3194 End If

3195 Index% = CInt(IndexStr)

3196 str = Mid(str, p + 1)

3197 ConfirmStr$ = Trim(str)

3198 Dim Confirm As Boolean

3199 Select Case ConfirmStr

3200 Case sYes

3201 Confirm = True

3202 Case sNo

3203 Confirm = False

3204 Case Default

3205 Call ErrorInQuery

3206 Exit Sub

3207 End Select

3208

3209 Select Case what

3210 Case sCol

3211 If (DB(QRDBIndex). Header. ColCount > 0) Then

3212 Call DelCol_(QRDBIndex, Index, Confirm)

3213 Else

3214 Call MsgForm. ErrorMsg("В БД нет полей! ")

3215 Exit Sub

3216 End If

3217 Case sRow

3218 If (DB(QRDBIndex). Header. RowCount > 0) Then

3219 Call DelRow_(QRDBIndex, Index, Confirm)

3220 Else

3221 Call MsgForm. ErrorMsg("В БД нет записей! ")

3222 Exit Sub

3223 End If

3224 End Select

3225End Sub

3226

3227Sub SortRun(str$)

3228 If (DB(QRDBIndex). Header. ColCount = 0) Or (DB(QRDBIndex). Header. RowCount = 0) Then

3229 Call MsgForm. ErrorMsg("Нечего сортировать! ")

3230 Exit Sub

3231 End If

3232

3233 p% = InStr(1, str, ",")

3234 If TestZero(p) Then Exit Sub

3235 what$ = Trim(Left(str, p - 1))

3236

3237 If (Not IsInteger(what)) Then

3238 Call ErrorInQuery

3239 Exit Sub

3240 End If

3241

3242 whatint% = CInt(what)

3243

3244 If (whatint DB(QRDBIndex). Header. ColCount - 1) Then

3245 Call ErrorInQuery

3246 Exit Sub

3247 End If

3248

3249 Mode$ = Trim(Mid(str, p + 1))

3250

3251 Select Case Mode

3252 Case sAZ

3253 s$ = "А->Я"

3254 Case sZA

3255 s$ = "Я->А"

3256 Case Default

3257 Call ErrorInQuery

3258 Exit Sub

3259 End Select

3260

3261 Count% = MainForm. TabStrip. Tabs. Count

3262 ReDim Preserve DB(Count)

3263

3264 DB(Count) = DB(QRDBIndex)

3265

3266 MainForm. TabStrip. Tabs. Add pvCaption: =s, pvImage: =1

3267

3268 Dim find As Boolean, needswap As Boolean

3269 Dim tmp As TDBElem

3270 With DB(Count)

3271 Do

3272 find = False

3273 For R% = 1 To. Header. RowCount - 1

3274 If (Mode = sZA) Then

3275 needswap = (. Rows(R). Fields(whatint) >. Rows(R - 1). Fields(whatint))

3276 Else

3277 needswap = (. Rows(R). Fields(whatint) <. Rows(R - 1). Fields(whatint))

3278 End If

3279 If (needswap) Then

3280 tmp =. Rows(R)

3281. Rows(R) =. Rows(R - 1)

3282. Rows(R - 1) = tmp

3283 find = True

3284 End If

3285 Next R

3286 Loop While (find)

3287 End With

3288End Sub

3289

3290Function Equal(ByVal col%, ByVal row%, ByVal cmpstr$) As Long

3291 If (DB(QRDBIndex). Cols(col). Class = ccInteger) Then

3292 Rval = CLng(DB(QRDBIndex). Rows(row). Fields(col))

3293 Equal = (Rval - CLng(cmpstr))

3294 Else

3295 Rval = CStr(DB(QRDBIndex). Rows(row). Fields(col))

3296 If (Rval = cmpstr) Then

3297 Equal = 0

3298 Else

3299 If (Rval > cmpstr) Then

3300 Equal = 1

3301 Else

3302 Equal = - 1

3303 End If

3304 End If

3305 End If

3306End Function

3307

3308Function CalcCount(Index%, c%, value$) As Integer

3309 Count% = 0

3310 For i% = 0 To (DB(Index). Header. RowCount - 1)

3311 If (CStr(DB(Index). Rows(i). Fields(c)) = value) Then Count = Count + 1

3312 Next i

3313 CalcCount = Count

3314End Function

3315

3316Function EarlierDontFind(Index%, c%, R%, value$) As Boolean

3317 For i% = 0 To (R - 1)

3318 If (CStr(DB(Index). Rows(i). Fields(c)) = value) Then

3319 EarlierDontFind = False

3320 Exit Function

3321 End If

3322 Next i

3323 EarlierDontFind = True

3324End Function

3325

3326Public Function FindRow(Index%, row())

3327 For R% = 0 To DB(Index). Header. RowCount - 1

3328 Sum% = 0

3329 For c% = 0 To DB(Index). Header. ColCount - 1

3330 If (CStr(DB(Index). Rows(R). Fields(c)) = row(c)) Then Sum = Sum + 1

3331 Next c

3332 If (Sum = DB(Index). Header. ColCount) Then

3333 FindRow = True

3334 Exit Function

3335 End If

3336 Next R

3337 FindRow = False

3338End Function

3339

3340Sub OutRun(str$)

3341 If (DB(QRDBIndex). Header. ColCount = 0) Or (DB(QRDBIndex). Header. RowCount = 0) Then

3342 Call MsgForm. ErrorMsg("Не с чем сравнивать! ")

3343 Exit Sub

3344 End If

3345

3346 p% = InStr(1, str, ",")

3347 what$ = Trim(Left(str, p - 1))

3348

3349 If (Not IsInteger(what)) Then

3350 Call ErrorInQuery

3351 Exit Sub

3352 End If

3353

3354 whatint% = CInt(what)

3355

3356 If (whatint DB(QRDBIndex). Header. ColCount - 1) Then

3357 Call ErrorInQuery

3358 Exit Sub

3359 End If

3360

3361 pi% = p + 1

3362 Do

3363 Mode$ = Trim(Mid(str, pi, 1))

3364 pi = pi + 1

3365 Loop While (Mode = "")

3366 Mode = Mode + Mid(str, pi, 1)

3367

3368 If (Mode <> sEqual) And (Mode <> sAbove) And (Mode <> sBelow) And (Mode <> sCountEqual) And (Mode <> sCountAbove) And (Mode <> sCountBelow) Then

3369 Call ErrorInQuery

3370 Exit Sub

3371 End If

3372

3373 Dim CalcMode As Boolean

3374 CalcMode = (Mode = sCountEqual) Or (Mode = sCountAbove) Or (Mode = sCountBelow)

3375

3376 str = Trim(Mid(str, pi + 1))

3377

3378 If (str = "") Then

3379 Call ErrorInQuery

3380 Exit Sub

3381 End If

3382

3383 ' проверка на наличие индекса таблицы

3384 p = InStr(1, str, ",")

3385 tableindex% = - 1

3386 If (p <> 0) Then

3387 tableindexstr$ = Trim(Mid(str, p + 1))

3388 If Not IsInteger(tableindexstr) Then

3389 Call ErrorInQuery

3390 Exit Sub

3391 End If

3392 tableindex% = CLng(tableindexstr)

3393 If (tableindex MainForm. TabStrip. Tabs. Count - 1) Then

3394 Call ErrorInQuery

3395 Exit Sub

3396 End If

3397 str = Trim(Left(str, p - 1))

3398 End If

3399

3400 Dim GlobEqual As Boolean

3401 If (Not IsInteger(str)) And (DB(QRDBIndex). Cols(whatint). Class = ccInteger) Then

3402 Call MsgForm. ErrorMsg("Эквивалентом вывода целочисленного столбца не является целое число! " + vbCrLf + _

3403 "Условие всегда истинно! ")

3404 GlobEqual = True

3405 Else

3406 GlobEqual = False

3407 End If

3408

3409 Count% = MainForm. TabStrip. Tabs. Count

3410 If (tableindex = - 1) Then

3411 ReDim Preserve DB(Count)

3412

3413 DB(Count). Header = DB(QRDBIndex). Header

3414 DB(Count). Header. RowCount = 0

3415 DB(Count). Cols = DB(QRDBIndex). Cols

3416

3417 MainForm. TabStrip. Tabs. Add pvCaption: ="Вывод " + Mode + str, pvImage: =1

3418 Else

3419 Count = tableindex

3420 End If

3421

3422 Dim NeedAdd As Boolean

3423 With DB(Count)

3424 Dim Rval

3425 For R% = 0 To DB(QRDBIndex). Header. RowCount - 1

3426 If (Not GlobEqual) Then

3427 Select Case Mode

3428 Case sEqual

3429 NeedAdd = (Equal(whatint, R, str) = 0)

3430 Case sAbove

3431 NeedAdd = (Equal(whatint, R, str) > 0)

3432 Case sBelow

3433 NeedAdd = (Equal(whatint, R, str) < 0)

3434 Case sCountEqual

3435 value$ = CStr(DB(QRDBIndex). Rows(R). Fields(whatint))

3436 NeedAdd = ((CStr(CalcCount(QRDBIndex, whatint, value)) = str) And (EarlierDontFind(QRDBIndex, whatint, R, value)))

3437 Case sCountAbove

3438 value$ = CStr(DB(QRDBIndex). Rows(R). Fields(whatint))

3439 NeedAdd = ((CStr(CalcCount(QRDBIndex, whatint, value)) > str) And (EarlierDontFind(QRDBIndex, whatint, R, value)))

3440 Case sCountBelow

3441 value$ = CStr(DB(QRDBIndex). Rows(R). Fields(whatint))

3442 NeedAdd = ((CStr(CalcCount(QRDBIndex, whatint, value)) < str) And (EarlierDontFind(QRDBIndex, whatint, R, value)))

3443 End Select

3444 Else

3445 NeedAdd = True

3446 End If

3447 If (NeedAdd) Then

3448 ReDim tmparr(DB(QRDBIndex). Header. ColCount)

3449 tmparr = DB(QRDBIndex). Rows(R). Fields

3450 If (Not FindRow(Count, tmparr)) Then

3451 addindex% = DB(Count). Header. RowCount

3452 ReDim Preserve DB(Count). Rows(addindex)

3453 ReDim DB(Count). Rows(addindex). Fields(DB(Count). Header. ColCount - 1)

3454 DB(Count). Rows(addindex). Fields = DB(QRDBIndex). Rows(R). Fields

3455 DB(Count). Header. RowCount = DB(Count). Header. RowCount + 1

3456 Else

3457 Call MsgForm. ErrorMsg("Добавляемая запись уже существует! ")

3458 End If

3459 End If

3460 Next R

3461 End With

3462End Sub

3463

3464Sub SwapRun(what$, str$)

3465 p% = InStr(1, str, ",")

3466 If TestZero(p) Then Exit Sub

3467 index1str$ = Trim(Left(str, p - 1))

3468 index2str$ = Trim(Mid(str, p + 1))

3469

3470 If (Not IsInteger(index1str)) Then

3471 Call ErrorInQuery

3472 Exit Sub

3473 End If

3474

3475 index1% = CInt(index1str)

3476 index2% = CInt(index2str)

3477

3478 If (index1 < 0) Or (index2 < 0) Or (index1 = index2) Then

3479 Call ErrorInQuery

3480 Exit Sub

3481 End If

3482

3483 Select Case what

3484 Case sCol

3485 With DB(QRDBIndex)

3486 If (index1 >. Header. ColCount - 1) Or (index2 >. Header. ColCount - 1) Then

3487 Call ErrorInQuery

3488 Exit Sub

3489 End If

3490 ' обмен полей

3491 Dim tmpcol As TDBElemData

3492 tmpcol =. Cols(index1)

3493. Cols(index1) =. Cols(index2)

3494. Cols(index2) = tmpcol

3495 ' обмен полей записей

3496 Dim tmpcell As Variant

3497 For R% = 0 To. Header. RowCount - 1

3498 tmpcell =. Rows(R). Fields(index1)

3499. Rows(R). Fields(index1) =. Rows(R). Fields(index2)

3500. Rows(R). Fields(index2) = tmpcell

3501 Next R

3502

3503 End With

3504 Case sRow

3505 With DB(QRDBIndex)

3506 If (index1 >. Header. RowCount - 1) Or (index2 >. Header. RowCount - 1) Then