2259
2260' заголовок файла
2261TypeTDBHeader
2262 ' "DBX" - проверка файла
2263 Header As String * 3
2264 ' флаги
2265 Flags As Byte
2266 ' количество полей
2267 ColCountAsLong
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 ExitSub
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
2429EndFunction
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
2462EndSub
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 EndSelect
2556 Nexti
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 EndIf
2704
2705 ' считывание данных полей
2706 For i% = 0 To DBH. ColCount - 1
2707 ' получение класса
2708 GetDBI,, DB(DBIndex). Cols(i). Class
2709 ' получение длины заголовка
2710 Get DBI,, DB(DBIndex). Cols(i). TitleLen