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

2031 Chart. Width = Min

2032

2033 Min% = Height - dH + Screen. TwipsPerPixelY

2034 If (Min < 0) Then Min = 0

2035 Chart. Height = Min

2036

2037 VScroll. Left = Width - dX

2038

2039 Min% = Height - dH2 + Screen. TwipsPerPixelY

2040 If (Min < 0) Then Min = 0

2041 VScroll. Height = Min

2042

2043 Call DrawDiagram

2044End Sub

2045

2046Private Sub Image1_Click()

2047 CD. FileName = ""

2048 CD. ShowSave

2049 If (CD. FileName <> "") Then

2050 Call SavePicture(Chart. Image, CD. FileName)

2051 End If

2052End Sub

2053

2054Private Sub Image2_Click()

2055 With DiagOptForm

2056 ' цвета

2057. Frame2(0). BackColor = StartFillColor

2058. Frame2(1). BackColor = EndFillColor

2059. Frame2(2). BackColor = Chart. ForeColor

2060. Frame2(3). BackColor = LineColor

2061 ' размеры

2062. UpDown1. value = LineWidth

2063. UpDown2. value = d3D

2064. UpDown3. value = PointRadius

2065. UpDown4. value = LineCount

2066. UpDown5. value = Round(Ellipce * 100)

2067

2068. UpDown6. Max = Chart. Width

2069 If (Chart. Height < Chart. Width) Then. UpDown6. Max = Chart. Width

2070. UpDown6. Max = Round(. UpDown6. Max / Screen. TwipsPerPixelX)

2071. UpDown6. value = Round(Radius / Screen. TwipsPerPixelX)

2072

2073. UpDown7. Max =. UpDown6. Max * 0.9

2074. UpDown7. value = Round(InRad / Screen. TwipsPerPixelX)

2075

2076 ' цвета и надписи

2077. List1. Clear

2078 For i% = 1 To ItemCount

2079. List1. AddItem (DiagData(i - 1). Text)

2080. List1. ItemData(i - 1) = DiagData(i - 1). Color

2081 Next i

2082 If (. List1. ListCount > 0) Then. List1. ListIndex = 0

2083

2084 ' флаги

2085. Check1. value = - CInt(UseColorFill)

2086. Check3. value = - CInt(UseCircleLegend)

2087. Check2. value = - CInt(UseLineLeftValues)

2088

2089. Show vbModal

2090 If (. res = 1) Then

2091 ' цвета

2092 StartFillColor =. Frame2(0). BackColor

2093 EndFillColor =. Frame2(1). BackColor

2094 Chart. ForeColor =. Frame2(2). BackColor

2095 LineColor =. Frame2(3). BackColor

2096 ' размеры

2097 LineWidth =. UpDown1. value

2098 d3D =. UpDown2. value

2099 PointRadius =. UpDown3. value

2100 LineCount =. UpDown4. value

2101 Ellipce =. UpDown5. value / 100

2102 Radius =. UpDown6. value * Screen. TwipsPerPixelX

2103 InRad =. UpDown7. value * Screen. TwipsPerPixelX

2104 ' цвета и надписи

2105 For i% = 1 To ItemCount

2106 DiagData(i - 1). Text =. List1. List(i - 1)

2107 DiagData(i - 1). Color =. List1. ItemData(i - 1)

2108 Next i

2109 ' флаги

2110 UseColorFill = (. Check1. value = 1)

2111 UseCircleLegend = (. Check3. value = 1)

2112 UseLineLeftValues = (. Check2. value = 1)

2113 Call DrawDiagram

2114 End If

2115 End With

2116End Sub

2117

2118Private Sub Image3_Click()

2119 Hide

2120End Sub

2121

2122Private Sub VScroll_Change()

2123 Ellipce = VScroll. value / 100

2124 Call DrawDiagram

2125End Sub

Форма: InputForm. frm

2126Dim res%

2127

2128Private Sub CancelBut_Click()

2129 Call SoundClick

2130 Hide

2131End Sub

2132

2133Private Sub Form_Activate()

2134 Text1. SetFocus

2135End Sub

2136

2137Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

2138 Select Case KeyCode

2139 Case 13: Call YesBut_Click

2140 Case 27: Call CancelBut_Click

2141 End Select

2142End Sub

2143

2144Private Sub Form_Load()

2145 Call ButEnabled(YesImg, YesBut, True)

2146 Call ButEnabled(CancelImg, CancelBut, True)

2147End Sub

2148

2149Public Function InputVal(str$) As String

2150 Label1. Caption = str

2151 Text1. Text = ""

2152 res = 0

2153 Me. Show vbModal

2154 If (res = 1) Then InputVal = Text1. Text

2155 Unload Me

2156End Function

2157

2158Private Sub YesBut_Click()

2159 Call SoundClick

2160 res = 1

2161 Hide

2162End Sub

Форма: DiagOpt. frm

2163Public res%

2164

2165Private Sub Form_Load()

2166 res = 0

2167 Call ButEnabled(SelectImg, SelectBut, True)

2168 Call ButEnabled(CancelImg, CancelBut, True)

2169End Sub

2170

2171Private Sub Form_Paint()

2172 Call DiagResForm. ColorFill(Picture1, Frame2(0). BackColor, Frame2(1). BackColor)

2173End Sub

2174

2175Private Sub Frame2_Click(Index As Integer)

2176 ColorDlg. Color = Frame2(Index). BackColor

2177 ColorDlg. ShowColor

2178 Frame2(Index). BackColor = ColorDlg. Color

2179 If (Index < 2) Then Call DiagResForm. ColorFill(Picture1, Frame2(0). BackColor, Frame2(1). BackColor)

2180 If (Index = 4) Then List1. ItemData(List1. ListIndex) = Frame2(4). BackColor

2181End Sub

2182

2183Private Sub Label10_Click()

2184 res = 1

2185 Hide

2186End Sub

2187

2188Private Sub Label15_Click()

2189 Hide

2190End Sub

2191

2192Private Sub List1_Click()

2193 If (List1. ListIndex > - 1) Then

2194 Text1. Text = List1. List(List1. ListIndex)

2195 Frame2(4). BackColor = List1. ItemData(List1. ListIndex)

2196 End If

2197End Sub

2198

2199Private Sub List1_KeyPress(KeyAscii As Integer)

2200 Call List1_Click

2201End Sub

2202

2203Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)

2204 If (KeyCode = 13) Then

2205 List1. List(List1. ListIndex) = Text1. Text

2206 List1. ItemData(List1. ListIndex) = Frame2(4). BackColor

2207 End If

2208End Sub

Форма: SplashScreenForm. frm

2209Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

2210 If (KeyCode = 27) Or (KeyCode = 13) Then

2211 MainForm. Show

2212 Unload Me

2213 End If

2214End Sub

2215

2216Private Sub Form_Load()

2217 Label2. Caption = "v. " + CStr(App. Major) + ". " + CStr(App. Minor)

2218End Sub

2219

2220Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

2221 Call MDown(x, y)

2222End Sub

2223

2224Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

2225 Call MMove(hwnd, x, y)

2226End Sub

2227

2228Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

2229 Call MUp

2230End Sub

Форма: MonthForm. frm

2231Public res%

2232

2233Private Sub CancelBut_Click()

2234 Hide

2235End Sub

2236

2237Private Sub EditBut_Click()

2238 res = - 1

2239 Hide

2240End Sub

2241

2242Private Sub Form_Load()

2243 Call ButEnabled(YesImg, YesBut, True)

2244 Call ButEnabled(EditImg, EditBut, True)

2245 Call ButEnabled(CancelImg, CancelBut, True)

2246 res = 0

2247End Sub

2248

2249Private Sub YesBut_Click()

2250 res = 1

2251 Hide

2252End Sub

Модуль: DBTypes. bas

2253'************************************

2254' модуль DBTypes. bas

2255' вся работа с файлом БД

2256'************************************

2257

2258'************************************** Описание типов **************************************

2259

2260' заголовок файла

2261Type TDBHeader

2262 ' "DBX" - проверка файла

2263 Header As String * 3

2264 ' флаги

2265 Flags As Byte

2266 ' количество полей

2267 ColCount As Long

2268 ' количество записей

2269 RowCount As Long

2270End Type

2271

2272' имеет ли пользователь права на редактирование

2273Public UserIsAdmin As Boolean

2274

2275' данные о столбце

2276Type TDBElemData

2277 ' тип данных

2278 Class As Byte

2279 ' длина заголовка

2280 TitleLen As Byte

2281 ' заголовок, длины TitleLen

2282 title As String

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

2284 DefValue As Variant

2285End Type

2286

2287' запись

2288Type TDBElem

2289 ' поля записи

2290 Fields() As Variant

2291End Type

2292

2293' элемент в массиве DB

2294Type TDBCell

2295 Header As TDBHeader

2296 Cols() As TDBElemData

2297 Rows() As TDBElem

2298 Password As String

2299End Type

2300

2301'************************************** Описание констант **************************************

2302

2303' контрольный байт

2304Public Const ValidateByte As Byte = &H7F

2305

2306'************************************** Описание переменных **************************************

2307

2308' путь к БД

2309Public DBPath$

2310' флаг изменения БД

2311Public DBChanged As Boolean

2312' данные таблиц: каждый элемент - это копия некоторой таблицы

2313Public DB() As TDBCell

2314

2315'************************************** Процедуры и функции **************************************

2316

2317' удаление поля

2318Public Sub DelCol_(DBIndex%, Optional ByVal Index% = - 1, Optional ByVal conf As Boolean = True)

2319 With DB(DBIndex). Header

2320 If (. ColCount = 0) Then Exit Sub

2321 If (Index = - 1) Then Index =. ColCount - 1

2322 If (Index >. ColCount - 1) Or (Index < - 1) Then

2323 Call MsgForm. ErrorMsg("Ошибка удаления столбца! ")

2324 Exit Sub

2325 End If

2326

2327 If conf Then

2328 If (MsgForm. QuestMsg("Удалить столбец? ") <> resOk) Then Exit Sub

2329 End If

2330 ' вырезаю из полей

2331 For i% = Index To (. ColCount - 2)

2332 DB(DBIndex). Cols(i) = DB(DBIndex). Cols(i + 1)

2333 Next i

2334 ' вырезаю из записей

2335 For R% = 0 To (. RowCount - 1)

2336 For c% = Index To (. ColCount - 2)

2337 DB(DBIndex). Rows(R). Fields(c) = DB(DBIndex). Rows(R). Fields(c + 1)

2338 Next c

2339 Next R

2340

2341. ColCount =. ColCount - 1

2342 ReDim Preserve DB(DBIndex). Cols(. ColCount)

2343 DBChanged = True

2344End With

2345End Sub

2346

2347' удаление записи

2348Public Sub DelRow_(DBIndex%, Optional ByVal Index% = - 1, Optional ByVal conf As Boolean = True)

2349 With DB(DBIndex). Header

2350 If (. RowCount = 0) Then Exit Sub

2351 If (Index = - 1) Then Index =. RowCount - 1

2352 If (Index >. RowCount - 1) Then

2353 Call MsgForm. ErrorMsg("Ошибка удаления записи! ")

2354 Exit Sub

2355 End If

2356

2357 If conf Then

2358 If (MsgForm. QuestMsg("Удалить запись? ") = resNo) Then Exit Sub

2359 End If

2360 For i% = Index To (. RowCount - 2)

2361 DB(DBIndex). Rows(i) = DB(DBIndex). Rows(i + 1)

2362 Next i

2363. RowCount =. RowCount - 1

2364 ReDim Preserve DB(DBIndex). Rows(. RowCount)

2365 DBChanged = True

2366End With

2367End Sub

2368

2369Public Sub TestDBChanged()

2370 If DBChanged Then

2371 MainForm. SB. Panels(1). Picture = MainForm. ImageList1. ListImages(2). Picture

2372 Else

2373 Set MainForm. SB. Panels(1). Picture = Nothing

2374 End If

2375End Sub

2376

2377' отображение таблицы

2378Public Sub ShowTable(DBIndex%)

2379 MainForm. ListView. ListItems. Clear

2380 MainForm. ListView. ColumnHeaders. Clear

2381 If (DBIndex = - 1) Then

2382 DBPath = ""

2383 MainForm. SB. Panels(3). Text = ""

2384 GoTo exit_

2385 End If

2386 If (DB(DBIndex). Header. ColCount = 0) Then GoTo exit_

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

2388 Call MainForm. ListView. ColumnHeaders. Add(_

2389 MainForm. ListView. ColumnHeaders. Count + 1, _

2390 "col_key_" + CStr(c), _

2391 DB(DBIndex). Cols(c). title, _

2392 1440, _

2393 lvwColumnLeft, _

2394 0 _

2395)

2396

2397 Next c

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

2399 With MainForm. ListView. ListItems. Add

2400. Key = "row_key_" + CStr(R)

2401. Text = DB(DBIndex). Rows(R). Fields(0)

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

2403. SubItems(i) = DB(DBIndex). Rows(R). Fields(i)

2404 Next i

2405 End With

2406 Next R

2407exit_:

2408 MainForm. TabStrip. Visible = (DBPath <> "")

2409 MainForm. ListView. Visible = MainForm. TabStrip. Visible

2410 If (DBIndex <> - 1) Then

2411 MainForm. SB. Panels(2). Text = CStr(DB(DBIndex). Header. RowCount)

2412 Else

2413 MainForm. SB. Panels(2). Text = ""

2414 End If

2415 Call TestDBChanged

2416End Sub

2417

2418' поиск поля *************************************************

2419Public Function ItColAlreadyCreate(QRDBIndex%, title$) As Boolean

2420 With DB(QRDBIndex)

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

2422 If (. Cols(i). title = title) Then

2423 ItColAlreadyCreate = True

2424 Exit Function

2425 End If

2426 Next i

2427 End With

2428 ItColAlreadyCreate = False

2429End Function

2430

2431' добавление поля *************************************************

2432Public Sub AddCol(DBIndex%, ByVal Class%, ByVal title$, ByVal defval, Optional ByVal pos% = - 1)

2433 With DB(DBIndex). Header

2434 ReDim Preserve DB(DBIndex). Cols(. ColCount)

2435 If (pos = - 1) Then

2436 pos =. ColCount

2437 Else

2438 For i% = 1 To (. ColCount - pos)

2439 DB(DBIndex). Cols(. ColCount - i + 1) = DB(DBIndex). Cols(. ColCount - i)

2440 Next i

2441 End If

2442 With DB(DBIndex). Cols(pos)

2443. Class = Class

2444. title = title

2445. TitleLen = Len(title)

2446. DefValue = defval

2447 End With

2448

2449 ' увеличиваю размерность записей

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

2451 ReDim Preserve DB(DBIndex). Rows(R). Fields(. ColCount)

2452 For i% = 1 To (. ColCount - pos)

2453 DB(DBIndex). Rows(R). Fields(. ColCount - i + 1) = DB(DBIndex). Rows(R). Fields(. ColCount - i)

2454 Next i

2455 DB(DBIndex). Rows(R). Fields(pos) = DB(DBIndex). Cols(pos). DefValue

2456 Next R

2457

2458. ColCount =. ColCount + 1

2459

2460 DBChanged = True

2461 End With

2462End Sub

2463

2464' добавление записи *************************************************

2465Public Sub AddField(DBIndex%, row)

2466 With DB(DBIndex). Header

2467 ReDim Preserve DB(DBIndex). Rows(. RowCount)

2468 DB(DBIndex). Rows(. RowCount). Fields = row

2469. RowCount =. RowCount + 1

2470 DBChanged = True

2471 End With

2472End 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("Недостаточно прав для выполнения действия! ")

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"

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 < 0) Or (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 < 0) Or (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 < 0) Or (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

3507 Call ErrorInQuery

3508 Exit Sub

3509 End If

3510 Dim tmprow As TDBElem

3511 tmprow =. Rows(index1)

3512. Rows(index1) =. Rows(index2)

3513. Rows(index2) = tmprow

3514 End With

3515 End Select

3516End Sub

3517

3518Sub ChangeRun(what$, param$)

3519 Select Case what

3520 Case sType ' **************...::: Type:::... ***************

3521 If Not IsInteger(param) Then

3522 Call ErrorInQuery

3523 Exit Sub

3524 End If

3525 colindex% = CLng(param)

3526 If (colindex < 0) Or (colindex > DB(QRDBIndex). Header. ColCount - 1) Then

3527 Call ErrorInQuery

3528 Exit Sub

3529 End If

3530 If (DB(QRDBIndex). Cols(colindex). Class = ccString) Then

3531 If (MsgForm. QuestMsg("Поле строкового типа преобразуется в числовой тип. " + _

3532 "Все нечисловые значения будут преобразованы в 0. " + _

3533 "Продолжить? ") <> resOk) Then Exit Sub

3534

3535 End If

3536 For i% = 0 To (DB(QRDBIndex). Header. RowCount - 1)

3537 Select Case DB(QRDBIndex). Cols(colindex). Class

3538 Case ccInteger

3539 DB(QRDBIndex). Rows(i). Fields(colindex) = CStr(DB(QRDBIndex). Rows(i). Fields(colindex))

3540 Case ccString

3541 If Not IsInteger(DB(QRDBIndex). Rows(i). Fields(colindex)) Then

3542 DB(QRDBIndex). Rows(i). Fields(colindex) = 0

3543 Else

3544 DB(QRDBIndex). Rows(i). Fields(colindex) = CLng(DB(QRDBIndex). Rows(i). Fields(colindex))

3545 End If

3546 End Select

3547 Next i

3548 Select Case DB(QRDBIndex). Cols(colindex). Class

3549 Case ccInteger

3550 DB(QRDBIndex). Cols(colindex). Class = ccString

3551 Case ccString

3552 DB(QRDBIndex). Cols(colindex). Class = ccInteger

3553 End Select

3554

3555 Case sName ' **************...::: Name:::... ***************

3556 p% = InStr(1, param, ",")

3557 If TestZero(p) Then Exit Sub

3558 colindexstr$ = Trim(Left(param, p - 1))

3559 If Not IsInteger(colindexstr) Then

3560 Call ErrorInQuery

3561 Exit Sub

3562 End If

3563 colindex% = CLng(colindexstr)

3564 param = Trim(Mid(param, p + 1))

3565 If (param = "") Then

3566 Call ErrorInQuery

3567 Exit Sub

3568 End If

3569 ' поиск на дубликат

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

3571 If (DB(QRDBIndex). Cols(i). title = param) And (i <> colindex) Then

3572 Call MsgForm. ErrorMsg("Поле с названием " + param + " уже существует! ")

3573 Exit Sub

3574 End If

3575 Next i

3576 DB(QRDBIndex). Cols(colindex). title = param

3577 DB(QRDBIndex). Cols(colindex). TitleLen = Len(param)

3578 Case Default ' **************!! ***************

3579 Call ErrorInQuery

3580 End Select

3581End Sub

3582

3583Public Sub RunQuery(DBIndex_%, query$)

3584 Dim s1$, p%

3585

3586 s1 = Mid(query, 4)

3587 query = Left(query, 3)

3588

3589 QRDBIndex = DBIndex_

3590

3591 Select Case query

3592 Case sAdd

3593 query = Left(s1, 3)

3594 s1 = Mid(s1, InStr(1, s1, "("))

3595 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or ((Len(s1) < 8) And (query = sCol)) Then

3596 Call ErrorInQuery

3597 Else

3598 Call AddRun(query, Trim(Mid(s1, 2, Len(s1) - 2)))

3599 End If

3600 Case sDel

3601 query = Left(s1, 3)

3602 s1 = Mid(s1, InStr(1, s1, "("))

3603 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or (Len(s1) < 5) Then

3604 Call ErrorInQuery

3605 Else

3606 Call DelRun(query, Trim(Mid(s1, 2, Len(s1) - 2)))

3607 End If

3608 Case sSort

3609 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or (Len(s1) < 5) Then

3610 Call ErrorInQuery

3611 Else

3612 Call SortRun(Trim(Mid(s1, 2, Len(s1) - 2)))

3613 End If

3614 Case sOut

3615 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or (Len(s1) < 5) Then

3616 Call ErrorInQuery

3617 Else

3618 Call OutRun(Trim(Mid(s1, 2, Len(s1) - 2)))

3619 End If

3620 Case sSwap

3621 query = Left(s1, 3)

3622 s1 = Mid(s1, InStr(1, s1, "("))

3623 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or ((Len(s1) < 5) And (query = sCol)) Then

3624 Call ErrorInQuery

3625 Else

3626 Call SwapRun(query, Trim(Mid(s1, 2, Len(s1) - 2)))

3627 End If

3628 Case sChange

3629 query = Left(s1, 4)

3630 s1 = Mid(s1, InStr(1, s1, "("))

3631 If (Left(s1, 1) <> "(") Or (Right(s1, 1) <> ")") Or (Len(s1) < 3) Then

3632 Call ErrorInQuery

3633 Else

3634 Call ChangeRun(query, Trim(Mid(s1, 2, Len(s1) - 2)))

3635 End If

3636 End Select

3637

3638End Sub