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

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