Для сохранения БД в гипертекстовом формате воспользуйтесь пунктом меню Результаты>Формирование HTML. Достаточно указать путь к файлу и заголовок таблицы.

Для установки защиты выберите Настройки>Защита. Условием защиты по паролю является наличие произвольного, отличного от пробелов текста в поле ввода пароля. Если поле пусто никакие настройки не учитываются.

Для получения справки выберите? >Помощь.

3.2.3. Сообщения оператору (рис.12, рис.13, рис.14)
Мастер диаграмм:

Нельзя строить диаграмму по нечисловым данным! (попытка строить диаграмму по строковым значениям)

Редактор записей:

Восстановить поля из БД?

Поля были восстановлены!

Для редактирования чисел редактор не используется. (редактор предназначен лишь для удобства редактирования многострочного текста)

Сохранить поля в БД?

Поля были сохранены в БД!

Изменённое поле перекрывает уже существующее! Измените данные. (измененное поле стало эквивалентно другому полю, либо не было внесено изменений в данные)

Числовое значение превышает разрядную сетку! (введено целое число, большее по модулю 2147483647)

Значение не является целым числом! (введено значение, не являющееся целым числом либо 0)

Строка пуста. Продолжить? (измененная строка пуста)

Мастер запросов:

Запрос отменен!

Список запросов не пуст. Выйти? (были созданы и не выполнены запросы)

Очистить список запросов?

Удалить выбранный запрос из списка?

Запросы выполнены.

Выводить в новую таблицу? Нет для вывода в уже существующую. (запрос может выводить результат либо в уже существующую таблицу, дописывая в конец, либо создать новую)

Не задано относительное значение! (для выполнения запроса недостаточно данных)

Ошибка в запросе! (произошла ошибка во время интерпретации или выполнения запроса)

Добавляемое поле уже существует!

Добавляемый столбец дублируется!

Нельзя добавлять записи в БД без полей! (запись добавляется, а полей в БД еще нет)

В БД нет полей!

В БД нет записей!

Нечего сортировать! (вызвана сортировка пустой БД)

Не с чем сравнивать! (сравнения по пустой БД)

Эквивалентом вывода целочисленного столбца не является целое число! Условие всегда истинно! (в запросе вывода указано строковое значение, а вывод идет по числовому полю)

Добавляемая запись уже существует!

Поле строкового типа преобразуется в числовой тип. Все нечисловые значения будут преобразованы в 0. Продолжить? (при изменении типа поля из строкового в числовое все строки, которые нельзя преобразовать в целые числа, будут заменены 0).

Поле с названием XXX уже существует!

Окно настроек создаваемого поля:

Введенное значение не является целым числом. Преобразовано к '0'.

Главное окно:

Недостаточно прав для выполнения действия! (открыта БД, защищенная паролем, в режиме чтения и производится попытка изменения данных)

Ошибка удаления столбца!

Удалить столбец?

Ошибка удаления записи!

Удалить запись?

БД сохранена!

БД повреждена! (при загрузке БД произошла ошибка)

Пароль принят! (БД, защищенная паролем, открыта с корректно введенным паролем)

Только чтение! (БД, защищенная паролем, открыта в режиме чтения)

Пароль не принят! Доступ запрещён!

БД загружена!

БД создана с настройками по-умолчанию!

литература
Microsoft Corporation Microsoft Visual Basic 6.0 Programmer's Guide, Microsoft Press, 2003 г.
Microsoft® Win32® Programmer's Reference, 1996 г.
Приложение 1
Исходный код программы
Форма: MainForm. frm
0' разница ширины и высоты формы и TabStrip'а
1Dim dW1%, dH1%
2' разница ширины и высоты TabStrip'а и ListView'а
3Dim dW2%, dH2%
4' последний выбранный элемент
5Dim saveItemIndex%
6' текущая таблица
7Public DBCurIndex%
8' последний Image, над которым был курсор
9Dim OldImageIndex%
10
11Private Sub AboutProg_Click()
12 CoolTimer. Enabled = False
13 AboutForm. Show vbModal
14 CoolTimer. Enabled = True
15End Sub
16
17Private Sub CloseDB_Click()
18 CoolTimer. Enabled = False
19
20 If DBChanged Then
21 If (MsgForm. QuestMsg("В БД внесены не сохранённые изменения. Закрыть не сохраняя? ") <> resOk) Then GoTo exit_
22 End If
23
24 SB. Panels(3). Text = ""
25 Call ClearAll
26 Call ShowTable(-1)
27 Call DisEnImage(2, 1)
28 Call DisEnImage(3, 1)
29 Call DisEnImage(4, 1)
30
31exit_:
32
33 CoolTimer. Enabled = True
34End Sub
35
36' index,mode / сегмент, смещение
37Sub DisEnImage(Index%, Mode%)
38 CoolBut(Index). Picture = CoolImgs. ListImages(1 + (Index * 3 + Mode)). Picture
39 CoolBut(Index). Enabled = (Mode <> 1)
40End Sub
41
42Sub RetImage()
43 If (OldImageIndex > - 1) Then
44 If CoolBut(OldImageIndex). Enabled Then
45 Call DisEnImage(OldImageIndex, 0)
46 Else
47 Call DisEnImage(OldImageIndex, 1)
48 End If
49 End If
50 OldImageIndex = - 1
51End Sub
52
53Sub CoolMouseMove(Index%)
54 If (Index = OldImageIndex) Then Exit Sub
55 Call DisEnImage(Index, 2)
56 Call RetImage
57 OldImageIndex = Index
58End Sub
59
60Private Sub CoolBut_Click(Index As Integer)
61 Call DisEnImage(Index, 0)
62 Select Case Index
63 Case 0: Call CreateDB_Click
64 Case 1: Call OpenDB_Click
65 Case 2: Call SaveDB_Click
66 Case 3: Call CloseDB_Click
67 Case 4: Call ResCopyDB_Click
68 Case 5: Call ExitPr_Click
69 End Select
70End Sub
71
72Private Sub CoolTimer_Timer()
73 Dim Point As POINTAPI
74 Dim R As RECT, R2 As RECT
75 Call GetCursorPos(Point)
76 Call GetWindowRect(Frame1. hwnd, R)
77 For i% = 0 To 5
78 If (Not CoolBut(i). Enabled) Then GoTo loop_
79 x% = R. Left + CoolBut(i). Left / Screen. TwipsPerPixelX
80 y% = R. Top + CoolBut(i). Top / Screen. TwipsPerPixelY
81 X2% = x + CoolBut(i). Width / Screen. TwipsPerPixelX
82 Y2% = y + CoolBut(i). Height / Screen. TwipsPerPixelY
83 R2. Left = x
84 R2. Top = y
85 R2. Right = X2
86 R2. Bottom = Y2
87 If ((Point. x >= R2. Left) And (Point. x <= R2. Right) And (Point. y >= R2. Top) And (Point. y <= R2. Bottom)) Then
88 Call CoolMouseMove(i)
89 Exit Sub
90 End If
91loop_:
92 Next i
93 Call RetImage
94End Sub
95
96Private Sub CreateDB_Click()
97 CoolTimer. Enabled = False
98 Dlgs. FileName = ""
99 Dlgs. ShowSave
100 If (Dlgs. FileName <> "") Then
101 ' создаю новую БД
102 Call NewDB(Dlgs. FileName)
103 ' вывожу путь к БД
104 SB. Panels(3). Text = DBPath
105 ' разрешения
106 Call DisEnImage(2, 0)
107 Call DisEnImage(3, 0)
108 Call DisEnImage(4, 0)
109 Call ShowTable(DBCurIndex)
110 End If
111 CoolTimer. Enabled = True
112End Sub
113
114Private Sub DiagDraw_Click()
115 CoolTimer. Enabled = False
116 DiagMasterForm. Show vbModal
117 CoolTimer. Enabled = True
118End Sub
119
120Private Sub ExitBut_Click()
121 Call ExitPr_Click
122End Sub
123
124Private Sub ExitPr_Click()
125 CoolTimer. Enabled = False
126 If Not DBChanged Then
127 End
128 Else
129 If (MsgForm. QuestMsg("В БД внесены не сохранённые изменения. Выйти не сохраняя? ") = resOk) Then End
130 End If
131 CoolTimer. Enabled = True
132End Sub
133
134Private Sub File_Click()
135 SaveDB. Enabled = DBPath <> ""
136 CloseDB. Enabled = SaveDB. Enabled
137 ResCopyDB. Enabled = SaveDB. Enabled
138End Sub
139
140Private Sub HelpProg_Click()
141 CoolTimer. Enabled = False
142 Call ShellExecute(hwnd, "open", "Help\index. html", "", "", 0)
143 CoolTimer. Enabled = True
144End Sub
145
146Sub CreateHTML(Path$)
147 Call DeleteFile(Path)
148 DBI% = FreeFile
149 Open Path For Binary As DBI
150
151 Capt$ = InputForm. InputVal("Введите заголовок для таблицы")
152
153 HTMLHeader$ = Replace("<html><head><meta http-equiv=~Content-Language~ content=~ru~>" + _
154 "<meta http-equiv=~Content-Type~ content=~text/html; charset=windows-1251~>", "~", Chr(34))
155
156 HTMLInfo$ = "<title>" + Capt + "</title>"
157
158 HTMLStart$ = Replace("</head><body><div align=~center~><table border=~1~ cellspacing=~2~ style=~border-collapse: collapse~>", "~", Chr(34))
159
160 HTMLEnd$ = "</table></div><br><br><br><hr><i>Файл сгенерирован программой DB Xtension по содержимому БД </i><b>' " + DBPath + "' </b></body></html>"
161
162 HTMLCaption$ = Replace("<tr><td colspan=~" + CStr(DB(DBCurIndex). Header. ColCount) + "~ align=~center~ bgcolor=~#66CCFF~><font color=~#FFFF00~ size=~5~>" + Capt + "</font></td></tr>", "~", Chr(34))
163
164 HTMLRowS$ = "<tr>"
165 HTMLRowE$ = "</tr>"
166
167 If (DB(DBCurIndex). Header. ColCount > 0) Then ColWidth% = 100 \ DB(DBCurIndex). Header. ColCount
168
169 HTMLCols$ = Replace("<td bgcolor=~#999999~ width=~" + CStr(ColWidth) + "%~ align=~center~><b><font face=~Arial~ color=~#FFFFFF~>^</font></b></td>", "~", Chr(34))
170
171 HTMLCells$ = Replace("<td width=~" + CStr(ColWidth) + "%~ align=~center~>^</td>", "~", Chr(34))
172
173 Put DBI,, HTMLHeader
174 Put DBI,, HTMLInfo
175
176 If (DB(DBCurIndex). Header. ColCount > 0) Then
177 Put DBI,, HTMLStart
178 Put DBI,, HTMLCaption
179
180 Put DBI,, HTMLRowS
181 For c% = 0 To DB(DBCurIndex). Header. ColCount - 1
182 Put DBI,, Replace(HTMLCols, "^", CStr(DB(DBCurIndex). Cols(c). title))
183 Next c
184 Put DBI,, HTMLRowE
185
186 For R% = 0 To DB(DBCurIndex). Header. RowCount - 1
187 Put DBI,, HTMLRowS
188 For c% = 0 To DB(DBCurIndex). Header. ColCount - 1
189 tmp$ = CStr(DB(DBCurIndex). Rows(R). Fields(c))
190 If (Trim(tmp) = "") Then tmp = "  "
191 Put DBI,, Replace(HTMLCells, "^", tmp)
192 Next c
193 Put DBI,, HTMLRowE
194 Next R
195
196 Put DBI,, HTMLEnd
197 Else
198 Put DBI,, "</head><body>База не содержит данных</body></html>"
199 End If
200
201 Close DBI
202
203 If (MsgForm. QuestMsg("Файл '" + Path + "' создан. Открыть? ") = resOk) Then
204 Call ShellExecute(hwnd, "open", Path, "", "", 0)
205 End If
206End Sub
207
208Private Sub HTMLCreator_Click()
209 CoolTimer. Enabled = False
210 HTMLPath. FileName = ""
211 HTMLPath. ShowSave
212 If (HTMLPath. FileName <> "") Then
213 Call CreateHTML(HTMLPath. FileName)
214 Else
215 Call MsgForm. ErrorMsg("Формирование HTML-документа отменено! ")
216 End If
217 CoolTimer. Enabled = True
218End Sub
219
220Private Sub ListView_DblClick()
221 If (saveItemIndex > 0) Then
222 Load EditRecordForm
223 With EditRecordForm
224. CellList. Clear
225. ERFDBIndex = DBCurIndex
226 Call. LoadData(saveItemIndex - 1)
227 Call. OverloadList
228. Show vbModal
229 End With
230 End If
231End Sub
232
233Private Sub ListView_ItemClick(ByVal Item As MSComctlLib. ListItem)
234 saveItemIndex = Item. Index
235End Sub
236
237Private Sub ListView_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
238 saveItemIndex = 0
239End Sub
240
241Private Sub OptDB_Click()
242 Security. Enabled = DBPath <> ""
243End Sub
244
245Private Sub Form_Load()
246' регистрации расширения
247 Call ShellExecute(0, "", "assoc. exe", App. Path + "\" + App. EXEName + ". exe", "", 0)
248 DBCurIndex = 0
249 UserIsAdmin = True
250 saveItemIndex = 0
251 OldImageIndex = - 1
252 Call ClearAll
253 dW1 = Width - TabStrip. Width
254 dH1 = Height - TabStrip. Height
255 dW2 = Width - ListView. Width
256 dH2 = Height - ListView. Height
257 Call DisEnImage(0, 0)
258 Call DisEnImage(1, 0)
259 Call DisEnImage(2, 1)
260 Call DisEnImage(3, 1)
261 Call DisEnImage(4, 1)
262 Call DisEnImage(5, 0)
263End Sub
264
265Private Sub Form_Resize()
266 CoolBar1. Width = 2 * Width
267
268 Min% = MainForm. Width - dW2
269 If (Min < 0) Then: Min = 0
270 ListView. Width = Min
271
272 Min = MainForm. Height - dH2
273 If (Min < 0) Then: Min = 0
274 ListView. Height = Min
275
276 Min = MainForm. Width - dW1
277 If (Min < 0) Then: Min = 0
278 TabStrip. Width = Min
279
280 Min = MainForm. Height - dH1
281 If (Min < 0) Then: Min = 0
282 TabStrip. Height = Min
283End Sub
284
285Private Sub Form_Unload(Cancel%)
286 If DBChanged Then
287 If (MsgForm. QuestMsg("Выйти? ") = resNo) Then Cancel = 1
288 End If
289 Close ' пожалуй, это лишнее, но да мало ли:)
290End Sub
291
292Private Sub OpenDB_Click()
293 CoolTimer. Enabled = False
294 Dlgs. FileName = ""
295 Dlgs. ShowOpen
296 If (Dlgs. FileName <> "") Then
297 ' открываю БД
298 If LoadDB(DBCurIndex, Dlgs. FileName) Then
299 ' вывожу путь к БД
300 SB. Panels(3). Text = DBPath
301 Call DisEnImage(2, 0)
302 Call DisEnImage(3, 0)
303 Call DisEnImage(4, 0)
304 Call ShowTable(DBCurIndex)
305 End If
306 End If
307 CoolTimer. Enabled = True
308End Sub
309
310Private Sub QueryDB_Click()
311 QueryM. Enabled = DBPath <> ""
312End Sub
313
314Private Sub ResDB_Click()
315 DiagDraw. Enabled = DBPath <> ""
316 HTMLCreator. Enabled = DBPath <> ""
317End Sub
318
319Private Sub QueryM_Click()
320 CoolTimer. Enabled = False
321 With QueryMasterForm
322. QMFDBIndex = DBCurIndex
323. Show vbModal
324 End With
325 CoolTimer. Enabled = True
326End Sub
327
328Private Sub ResCopyDB_Click()
329 CoolTimer. Enabled = False
330 Dlgs. FileName = ""
331 Dlgs. ShowSave
332 If (Dlgs. FileName <> "") Then
333 If (Dlgs. FileName = DBPath) Then
334 Call MsgForm. ErrorMsg("Нельзя копировать файл сам в себя! ")
335 Else
336 Call CopyFile(DBPath, Dlgs. FileName, False)
337 Call MsgForm. InfoMsg("Архивная копия БД создана. ")
338 End If
339 Else
340 Call MsgForm. ErrorMsg("Резервное копирование БД отменено! ")
341 End If
342 CoolTimer. Enabled = True
343End Sub
344
345Private Sub SaveDB_Click()
346 CoolTimer. Enabled = False
347 Dlgs. FileName = ""
348 Dlgs. ShowSave
349 If (Dlgs. FileName <> "") Then
350 DBPath = Dlgs. FileName
351 Call FlushDB(DBCurIndex)
352 End If
353 CoolTimer. Enabled = True
354End Sub
355
356Private Sub Security_Click()
357 CoolTimer. Enabled = False
358 If UserIsAdmin Then
359 With PasswordForm
360. SetPassText = DB(DBCurIndex). Password
361
362 If (DB(DBCurIndex). Header. Flags And flCoded) Then
363. CheckCoded = 1
364 Else
365. CheckCoded = 0
366 End If
367 If (DB(DBCurIndex). Header. Flags And flReadOnlyEnable) Then
368. CheckNoRO = 1
369 Else
370. CheckNoRO = 0
371 End If
372. CaptionLabel = "Настройка защиты"
373. TextLabel = "Вы можете изменить пароль и права доступа к данной БД. Наличие пароля предполагает ограниченный доступ. "
374. Frame1. Visible = False
375. Frame2. Visible = True
376. Show vbModal
377 If (. res) Then
378 DB(DBCurIndex). Header. Flags = 0
379 If (Trim(. SetPassText) <> "") Then
380 DB(DBCurIndex). Password = Trim(. SetPassText)
381 DB(DBCurIndex). Header. Flags = flPasswordNeed
382 Call MsgForm. InfoMsg("Был задан пароль! ")
383 End If
384 DB(DBCurIndex). Header. Flags = DB(DBCurIndex). Header. Flags + (flCoded *. CheckCoded) + (flReadOnlyEnable *. CheckNoRO)
385 End If
386 Unload PasswordForm
387 End With
388 Else
389 Call ProtectedMsg
390 End If
391 CoolTimer. Enabled = True
392End Sub
393
394Private Sub TabStrip_Click()
395 If (TabStrip. Tabs. Count = 0) Then Exit Sub
396 If (DBCurIndex <> TabStrip. SelectedItem. Index - 1) Then
397 DBCurIndex = TabStrip. SelectedItem. Index - 1
398 Call ShowTable(DBCurIndex)
399End If
400End Sub
401
402Private Sub TabStrip_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
403 If (Shift = vbCtrlMask) Then PopupMenu TSMenu
404End Sub
405
406Private Sub TSClose_Click()
407 If (MsgForm. QuestMsg("Закрыть закладку? ") = resOk) Then
408 TabIndex% = TabStrip. SelectedItem. Index
409 TabStrip. Tabs. Remove (TabIndex)
410 Call DelTable(TabIndex - 1)
411
412 If (TabStrip. Tabs. Count = 0) Then
413 DBChanged = False
414 Call DisEnImage(2, 1)
415 Call DisEnImage(3, 1)
416 Call DisEnImage(4, 1)
417 Call ShowTable(-1)
418 Else
419 TabStrip. SelectedItem = TabStrip. Tabs. Item(1)
420 End If
421 End If
422End Sub
Форма: TableForm. frm
423Dim tmp As String
424
425Public Function AddColDlg(DBIndex%) As String
426 tmp = ""
427 With StCol
428. Clear
429 For i% = 1 To DB(DBIndex). Header. ColCount
430. AddItem DB(DBIndex). Cols(i - 1). title
431 Next
432. ListIndex =. ListCount - 1
433 End With
434 ColType. ListIndex = 0
435 Me. Show vbModal
436 AddColDlg = tmp
437 Unload Me
438End Function
439
440Private Sub ColType_Click()
441 ' изменение допустимых длин
442 If Visible Then
443 Select Case ColType. ListIndex
444 Case ccInteger: InitValue. MaxLength = 4
445 Case ccString: InitValue. MaxLength = 255
446 End Select
447 End If
448
449' контроль ввода
450 If Visible And (ColType. ListIndex = ccInteger) Then
451 If (Not IsInteger(InitValue. Text)) Then InitValue. Text = "0"
452 End If
453End Sub
454
455Private Sub CreateBut_Click()
456 Call SoundClick
457 s1$ = Trim(ColTitle. Text)
458 Do While (s1 = "")
459 s1 = Trim(InputForm. InputVal("Вы не ввели заголовок столбца. Повторите ввод. "))
460 Loop
461 tmp$ = s1 + ", "
462 Dim ct
463 Dim s2
464 Select Case ColType. ListIndex
465 Case ccInteger
466 t$ = Trim(InitValue. Text)
467 If (Not IsInteger(t)) Then
468 Call MsgForm. InfoMsg("Введённое значение не является целым числом. Преобразовано к '0'. ")
469 t = "0"
470 End If
471 tmp = tmp + " " + sI + ", " + t
472 Case ccString
473 t$ = Trim(InitValue. Text)
474 If (t = "") Then t = " "
475 tmp = tmp + " " + sS + ", " + t
476 End Select
477 Dim pos%
478 If (OnlyEndCheck. value = 1) Then
479 pos = - 1
480 Else
481 pos = StCol. ListIndex
482 If (Option2. value = True) Then pos = pos + 1
483 End If
484 tmp = tmp + ", " + CStr(pos)
485 Hide
486End Sub
487
488Private Sub CancelBut_Click()
489 Call SoundClick
490 Hide
491End Sub
492
493Private Sub Form_Load()
494 Call ButEnabled(CreateImg, CreateBut, True)
495 Call ButEnabled(CancelImg, CancelBut, True)
496End Sub
Форма: TextEditForm. frm
497Public res%
498Dim dW%, dH%
499
500Private Sub Form_Activate()
501 With TextEdit
502. SelStart = Len(. Text)
503 End With
504End Sub
505
506Private Sub Form_Load()
507 res = 0
508 dW = Width - TextEdit. Width
509 dH = Height - TextEdit. Height
510End Sub
511
512Private Sub Form_Resize()
513 Min% = Height - dH
514 If (Min <= 1000) Then: Min = 1000: Height = dH + Min
515 TextEdit. Height = Min
516
517 Min = Width - dW
518 If (Min <= 1000) Then: Min = 1000: Width = dW + Min
519 TextEdit. Width = Min
520End Sub
521
522Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib. Button)
523 On Error Resume Next
524 Select Case Button. Key
525 Case "ClearText"
526 TextEdit. TextRTF = ""
527 Case "SaveText"
528 res = 1
529 Hide
530 Case "CopyText"
531 Clipboard. SetText (TextEdit. SelText)
532 Case "PasteText"
533 TextEdit. SelText = VB. Clipboard. GetText
534 Case "CutText"
535 Clipboard. SetText (TextEdit. SelText)
536 TextEdit. SelText = ""
537 Case "DeleteText"
538 TextEdit. SelText = ""
539 Case "Properties"
540 On Error GoTo checkerror
541 FontDlg. ShowFont
542 TextEdit. Font. Name = FontDlg. FontName
543 TextEdit. Font. Bold = FontDlg. FontBold
544 TextEdit. Font. Italic = FontDlg. FontItalic
545 TextEdit. Font. Size = FontDlg. FontSize
546 TextEdit. Font. Strikethrough = FontDlg. FontStrikethru
547 TextEdit. Font. Underline = FontDlg. FontUnderline
548 Exit Sub
549checkerror:
550 MsgBox "error"
551 End Select
552End Sub
553
Форма: SelectForm. frm
554Dim tmp%, tmps$
555
556Public Function SelectDlg(DBIndex%, ByVal title$, ByVal what$) As Integer
557 Dim s$
558 List1. Visible = True
559 List2. Visible = False
560 List1. Clear
561 Select Case what
562 Case sRow ' *******************...::: Select Row:::... ********************
563 With MainForm. ListView. ListItems
564 For i% = 1 To. Count
565 s = CStr(i - 1) + ")" +. Item(i)
566 For j% = 1 To DB(DBIndex). Header. ColCount - 1
567 s = s + " - " +. Item(i). SubItems(j)
568 Next j
569 List1. AddItem s
570 Next i
571 End With
572
573 Case sCol ' *******************...::: Select Col:::... ********************
574 With MainForm. ListView. ColumnHeaders
575 For i% = 1 To. Count
576 List1. AddItem CStr(i - 1) + ")" +. Item(i)
577 Next i
578 End With
579
580 Case sTable ' *******************...::: Select Table:::... ********************
581 For i% = 0 To (MainForm. TabStrip. Tabs. Count - 1)
582 List1. AddItem CStr(i) + ")" + MainForm. TabStrip. Tabs. Item(i + 1)
583 Next i
584 End Select
585
586 If (List1. ListCount > 0) Then
587 List1. ListIndex = 0
588 Call ButEnabled(SelectImg, SelectBut, True)
589 Else
590 Call ButEnabled(SelectImg, SelectBut, False)
591 End If
592 Label1. Caption = title
593 tmp = - 1
594 Show vbModal
595 SelectDlg = CStr(tmp)
596End Function
597
598Public Function MultiSelectDlg(DBIndex%, ByVal title$, ByVal what$) As String
599 Dim s$
600 List2. Visible = True
601 List1. Visible = False
602 List2. Clear
603 CheckConfirm. Visible = False
604 If (what = sRow) Then
605 With MainForm. ListView. ListItems
606 For i% = 1 To. Count
607 s = CStr(i - 1) + ")" +. Item(i)
608 For j% = 1 To DB(DBIndex). Header. ColCount - 1
609 s = s + " - " +. Item(i). SubItems(j)
610 Next j
611 List2. AddItem s
612 Next i
613 End With
614 Else
615 With MainForm. ListView. ColumnHeaders
616 For i% = 1 To. Count
617 List2. AddItem CStr(i - 1) + ")" +. Item(i)
618 Next i
619 End With
620 End If
621 Call ButEnabled(SelectImg, SelectBut, False)
622 Label1. Caption = title
623 tmps = ""
624 Show vbModal
625 CheckConfirm. Visible = True
626 MultiSelectDlg = tmps
627End Function
628
629Private Sub Form_Activate()
630 Call ButEnabled(CancelImg, CancelBut, True)
631End Sub
632
633Private Sub SelectBut_Click()
634 If (SelectBut. Tag = 0) Then Exit Sub
635 If (List1. Visible) Then
636 tmp = List1. ListIndex
637 Else
638 For i = 0 To List2. ListCount - 1
639 If List2. Selected(i) Then tmps = tmps + CStr(i) + ","
640 Next i
641 tmps = Strings. Left$(tmps, Len(tmps) - 1)
642 End If
643 Hide
644End Sub
645
646Private Sub CancelBut_Click()
647 Hide
648End Sub
649
650Private Sub List1_Click()
651 Call ButEnabled(SelectImg, SelectBut, (List1. ListIndex <> - 1))
652End Sub
653
654Private Sub List2_Click()
655 Call ButEnabled(SelectImg, SelectBut, (List2. SelCount = 2))
656End Sub
Форма: QueryMasterForm. frm
657Public QMFDBIndex%
658
659Sub AddStr(str$)
660 If (str <> "") Then
661 QueryList. AddItem str
662 Else
663 Call MsgForm. ErrorMsg("Запрос отменен! ")
664 End If
665End Sub
666
667Private Sub AddImage_Click()
668Call SoundClick
669With QueryList
670 Select Case QueryTypeCombo. ListIndex
671 '******************* Добавление ***********************
672 Case 0
673 Select Case QuerySubtypeCombo. ListIndex
674 Case 0 ' добавление столбца
675 Call AddStr(Generate_Add(sCol))
676 Case 1 ' добавление записи
677 Call AddStr(Generate_Add(sRow))
678 End Select
679 '******************* Удаление ***********************
680 Case 1
681 Select Case QuerySubtypeCombo. ListIndex
682 Case 0 ' удаление столбца
683 Call AddStr(Generate_Del(sCol))
684 Case 1 ' удаление записи
685 Call AddStr(Generate_Del(sRow))
686 End Select
687
688 '******************* Сортировка ***********************
689 Case 2
690 Select Case QuerySubtypeCombo. ListIndex
691 Case 0 ' сортировка по алфавиту
692 Call AddStr(Generate_Sort(sAZ))
693 Case 1 ' сортировка против алфавита
694 Call AddStr(Generate_Sort(sZA))
695 End Select
696
697 '******************* Вывод ***********************
698 Case 3
699 Select Case QuerySubtypeCombo. ListIndex
700 Case 0 ' вывод на равенство записи
701 Call AddStr(Generate_Out(sEqual))
702 Case 1 ' вывод больше записи
703 Call AddStr(Generate_Out(sAbove))
704 Case 2 ' вывод меньше записи
705 Call AddStr(Generate_Out(sBelow))
706 Case 3 ' вывод на равенство кол-ву
707 Call AddStr(Generate_Out(sCountEqual))
708 Case 4 ' вывод больше кол-ва
709 Call AddStr(Generate_Out(sCountAbove))
710 Case 5 ' вывод меньше кол-ва
711 Call AddStr(Generate_Out(sCountBelow))
712 End Select
713
714 '******************* Обмен ***********************
715 Case 4
716 Select Case QuerySubtypeCombo. ListIndex
717 Case 0 ' обмен столбцов
718 Call AddStr(Generate_Swap(sCol))
719 Case 1 ' обмен строк
720 Call AddStr(Generate_Swap(sRow))
721 End Select
722
723 '******************* Смена ***********************
724 Case 5
725 Select Case QuerySubtypeCombo. ListIndex
726 Case 0 ' смена типа поля
727 Call AddStr(Generate_Change(sType))
728 Case 1 ' смена названия поля
729 Call AddStr(Generate_Change(sName))
730 End Select
731 End Select
732
733End With
734End Sub
735
736Private Sub CancelBut_Click()
737 Call SoundClick
738 If (QueryList. ListCount > 0) Then
739 If (MsgForm. QuestMsg("Список запросов не пуст. Выйти? ") = resOk) Then Unload Me
740 Else
741 Unload Me
742 End If
743End Sub
744
745' замена запроса
746Private Sub ChangeImage_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
747 If (Trim(Text1) <> "") Then
748 Call SoundClick
749 With QueryList
750 If (. ListIndex = - 1) Or (Shift And vbShiftMask <> 0) Then
751. AddItem Text1
752 Else
753. List(. ListIndex) = Text1
754 End If
755 End With
756 End If
757 Text1 = ""
758 Text1. SetFocus
759End Sub
760
761' очистка запросов
762Private Sub ClearImage_Click()
763 If (QueryList. ListCount > 0) Then
764 Call SoundClick
765 If (MsgForm. QuestMsg("Очистить список запросов? ") = resOk) Then
766 QueryList. Clear
767 Text1 = ""
768 Text1. SetFocus
769 End If
770 End If
771End Sub
772
773' удаление запроса
774Private Sub DelImage_Click()
775 If (QueryList. ListIndex >= 0) Then
776 Call SoundClick
777 If (MsgForm. QuestMsg("Удалить выбранный запрос из списка? ") = resOk) Then
778 QueryList. RemoveItem QueryList. ListIndex
779 Text1 = ""
780 Text1. SetFocus
781 End If
782 End If
783End Sub
784
785Private Sub Form_Load()
786 QueryTypeCombo. ListIndex = 0
787 Call ButEnabled(RunImg, RunBut, True)
788 Call ButEnabled(CancelImg, CancelBut, True)
789 TopImg. Picture = MainForm. TopImageList. ListImages(1). Picture
790End Sub
791
792Private Sub QueryList_DblClick()
793 With QueryList
794 If (. ListIndex <> - 1) Then
795 Text1 =. List(. ListIndex)
796 Text1. SetFocus
797 End If
798 End With
799End Sub
800
801Private Sub QueryTypeCombo_Click()
802 With QuerySubtypeCombo
803. Clear
804 Select Case QueryTypeCombo. ListIndex
805 Case 0
806. AddItem "Поля"
807. AddItem "Записи"
808 Case 1
809. AddItem "Поля"
810. AddItem "Записи"
811 Case 2
812. AddItem "По алфавиту"
813. AddItem "Против алфавита"
814 Case 3
815. AddItem "Равно записи"
816. AddItem "Больше записи"
817. AddItem "Меньше записи"
818. AddItem "Равно кол-ву копий"
819. AddItem "Больше кол-ва копий"
820. AddItem "Меньше кол-ва копий"
821 Case 4
822. AddItem "Полей"
823. AddItem "Записей"
824 Case 5
825. AddItem "Типа поля"
826. AddItem "Названия поля"
827 End Select
828. ListIndex = 0
829 End With
830End Sub
831
832Private Sub RunBut_Click()
833 If (QueryList. ListCount > 0) Then
834 Call SoundClick
835 For i% = 0 To QueryList. ListCount - 1
836 Call RunQuery(QMFDBIndex, QueryList. List(i))
837 Next i
838 With MainForm
839. TabStrip. SelectedItem =. TabStrip. Tabs(QMFDBIndex + 1)
840 Call ShowTable(QMFDBIndex)
841 End With
842 QueryList. Clear
843 Call MsgForm. InfoMsg("Запросы выполнены. ")
844 End If
845End Sub
846
847Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
848 If (KeyCode = 13) Then Call ChangeImage_MouseDown(vbLeftButton, Shift, 1, 1)
849End Sub
Форма: EditRecordForm. frm
850Public ERFDBIndex%
851Dim RowIndexSave%
852Dim protect As Boolean
853Dim Arr()
854
855Public Sub LoadData(RowIndex%)
856 RowIndexSave = RowIndex
857 With DB(ERFDBIndex). Header
858 ReDim Arr(. ColCount, 1)
859 For i% = 0 To. ColCount - 1
860 Arr(i, 0) = DB(ERFDBIndex). Rows(RowIndex). Fields(i)
861 Arr(i, 1) = DB(ERFDBIndex). Cols(i). Class
862 Next i
863 End With
864End Sub
865
866Private Sub CellList_Click()
867 i% = CellList. ListIndex
868 Select Case Arr(i, 1)
869 Case ccInteger
870 Label6. Caption = "Поле числового типа"
871 Call ButEnabled(EditorImg, EditorBut, False)
872 Case ccString
873 Label6. Caption = "Поле строкового типа"
874 Call ButEnabled(EditorImg, EditorBut, True)
875 End Select
876 With Text1
877. Text = CStr(Arr(i, 0))
878. SelStart = 0
879. SelLength = Len(. Text)
880 End With
881End Sub
882
883Public Sub OverloadList()
884 CellList. Clear
885 For i% = 0 To DB(ERFDBIndex). Header. ColCount - 1
886 CellList. AddItem CStr(Arr(i, 0))
887 Next i
888 CellList. ListIndex = 0
889End Sub
890
891Private Sub Form_Load()
892 protect = False
893 Call ButEnabled(ReturnImg, ReturnBut, True)
894 Call ButEnabled(EditorImg, EditorBut, False)
895 Call ButEnabled(FlipImg, FlipBut, True)
896 Call ButEnabled(SelectImg, SelectBut, True)
897 Call ButEnabled(CancelImg, CancelBut, True)
898 TopImg. Picture = MainForm. TopImageList. ListImages(1). Picture
899
900' If (Not protect) Then
901' Call OverloadList
902' Else
903' protect = False
904' End If
905
906End Sub
907
908Private Sub ReturnBut_Click()
909 Call SoundClick
910 If (MsgForm. QuestMsg("Восстановить поля из БД? ") = resOk) Then
911 Call LoadData(RowIndexSave)
912 Call OverloadList
913 Call MsgForm. InfoMsg("Поля были восстановлены! ")
914 End If
915End Sub
916
917Private Sub EditorBut_Click()
918 If (EditorBut. Tag = 0) Then Exit Sub
919 Call SoundClick
920 i% = CellList. ListIndex
921 If (Arr(i, 1) = ccInteger) Then
922 Call MsgForm. InfoMsg("Для редактирования чисел редактор не исспользуется. ")
923 Exit Sub
924 End If
925 If IsDate(Text1. Text) And (MonthForm. Check1. value = 0) Then
926 s$ = Text1. Text
927 p% = InStr(1, s, ". ")
928 MonthForm. MonthView1. Day = CInt(Left(s, p - 1))
929 s = Mid(s, p + 1)
930 p% = InStr(1, s, ". ")
931 MonthForm. MonthView1. Month = CInt(Left(s, p - 1))
932 s = Mid(s, p + 1)
933 MonthForm. MonthView1. Year = CInt(s)
934
935 MonthForm. Show vbModal
936 Select Case MonthForm. res
937 Case 1
938 Text1. Text = CStr(MonthForm. MonthView1. Day) + ". " + CStr(MonthForm. MonthView1. Month) + ". " + CStr(MonthForm. MonthView1. Year)
939 Case - 1
940 GoTo text_
941 End Select
942 Else
943text_:
944 With TextEditForm
945. TextEdit. Text = Text1. Text
946 protect = True
947. Show vbModal
948 If (. res = 1) Then Text1. Text =. TextEdit. Text
949 Unload TextEditForm
950 End With
951 End If
952End Sub
953
954Private Sub SelectBut_Click()
955Call SoundClick
956If UserIsAdmin Then
957 If (MsgForm. QuestMsg("Сохранить поля в БД? ") = resOk) Then
958 With DB(ERFDBIndex)
959 Dim tmparr()
960 ReDim tmparr(. Header. ColCount)
961 For i% = 0 To. Header. ColCount - 1
962 tmparr(i) = Arr(i, 0)
963 Next i
964 If (Not FindRow(ERFDBIndex, tmparr)) Then
965 For i% = 0 To. Header. ColCount - 1
966. Rows(RowIndexSave). Fields(i) = Arr(i, 0)
967 Next i
968 DBChanged = True
969 Call MsgForm. InfoMsg("Поля были сохранены в БД! ")
970 Call ShowTable(ERFDBIndex)
971 Unload Me
972 Else
973 Call MsgForm. ErrorMsg("Изменённое поле перекрывает уже существующее! Измените данные. ")
974 End If
975 End With
976 End If
977Else
978 Call ProtectedMsg
979End If
980End Sub
981
982Private Sub CancelBut_Click()
983 Call SoundClick
984 Unload Me
985End Sub
986
987' Посимвольное сравнение str с '2147483647' - максимальным значением Long
988Function isVeryLong(str$) As Boolean
989 If (Left(str, 1) = "-") Then str = Mid(str, 2)
990 For i% = 1 To (10 - Len(str))
991 str = "0" + str
992 Next i
993
994 maxval$ = "2147483647"
995 For i% = 1 To 10
996 ch1$ = Mid(maxval, i, 1)
997 ch2$ = Mid(str, i, 1)
998 If (Asc(ch2) > Asc(ch1)) Then
999 isVeryLong = True
1000 GoTo exit_
1001 ElseIf (ch2 <> ch1) Then
1002 isVeryLong = False
1003 GoTo exit_
1004 End If
1005 Next i
1006 isVeryLong = False
1007exit_:
1008End Function
1009
1010Private Sub FlipBut_Click()
1011Call SoundClick
1012If UserIsAdmin Then
1013 tmp = Null
1014 i% = CellList. ListIndex
1015 mln% = 10
1016 If (Left(Text1. Text, 1) = "-") Then mln = mln + 1
1017 If (Arr(i, 1) = ccInteger) Then
1018 If (Len(Trim(Text1. Text)) > mln) Or (isVeryLong(Trim(Text1. Text))) Then
1019 Call MsgForm. ErrorMsg("Числовое значение превышает разрядную сетку! ")
1020 With Text1
1021. SelStart = 0
1022. SelLength = Len(. Text)
1023 End With
1024 GoTo exit_
1025 End If
1026
1027 If IsInteger(Trim(Text1. Text)) Then
1028 tmp = CLng(Text1. Text)
1029 Else
1030 Call MsgForm. ErrorMsg("Значение не является целым числом! ")
1031 With Text1
1032. SelStart = 0
1033. SelLength = Len(. Text)
1034 End With
1035 End If
1036 Else
1037 If (Trim(Text1. Text) = "") Then
1038 If (MsgForm. QuestMsg("Строка пуста. Продолжить? ") = resOk) Then
1039 tmp = Text1. Text
1040 GoTo exit_
1041 Else
1042 With Text1
1043. SelStart = 0
1044. SelLength = Len(. Text)
1045 End With
1046 End If
1047 Else
1048 tmp = Text1. Text
1049 End If
1050 End If
1051
1052 ' Введёное значение прошло контроль
1053 If (Not IsNull(tmp)) Then
1054 Select Case Arr(i, 1)
1055 Case ccInteger: Arr(i, 0) = CLng(tmp)
1056 Case ccString: Arr(i, 0) = CStr(tmp)
1057 End Select
1058 curpos% = CellList. ListIndex
1059 Call OverloadList
1060 CellList. ListIndex = curpos
1061 End If
1062exit_:
1063Else
1064 Call ProtectedMsg
1065End If
1066End Sub
1067
1068Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
1069 If (KeyCode = 13) Then FlipBut_Click
1070End Sub
Форма: MsgForm. frm
1071Dim res As Byte
1072
1073Public Function ErrorMsg(str$) As Integer
1074 Caption = "Ошибка"
1075 Text = str
1076
1077 YesFrame. Visible = True
1078 NoFrame. Visible = False
1079 CancelFrame. Visible = False
1080
1081 InfoImage. Visible = False
1082 ErrImage. Visible = True
1083 QuestImage. Visible = False
1084
1085 YesFrame. Move 2400
1086 res = resBad
1087 Call sndPlaySound("Data\Error. wav", SND_ASYNC + SND_FILENAME + SND_LOOP + SND_APPLICATION)
1088 Show vbModal
1089 ErrorMsg = res
1090 Unload Me
1091End Function
1092
1093Public Function InfoMsg(str$) As Integer
1094 Caption = "Информация"
1095 Text = str
1096
1097 YesFrame. Visible = True
1098 NoFrame. Visible = False
1099 CancelFrame. Visible = False
1100
1101 InfoImage. Visible = True
1102 ErrImage. Visible = False
1103 QuestImage. Visible = False
1104
1105 YesFrame. Move 2400
1106
1107 res = 0
1108 Call sndPlaySound("Data\Info. wav", SND_ASYNC + SND_FILENAME + SND_LOOP + SND_APPLICATION)
1109 Show vbModal
1110 InfoMsg = res
1111 Unload Me
1112End Function
1113
1114Public Function QuestMsg(str$, Optional showcancel As Boolean = False) As Integer
1115 Caption = "Вопрос"
1116 Text = str
1117
1118 If showcancel Then
1119 YesFrame. Visible = True
1120 NoFrame. Visible = True
1121 CancelFrame. Visible = True
1122
1123 YesFrame. Move 360
1124 NoFrame. Move 4380
1125 CancelFrame. Move 2400
1126
1127 Else
1128 YesFrame. Visible = True
1129 NoFrame. Visible = True
1130 CancelFrame. Visible = False
1131
1132 YesFrame. Move 900
1133 NoFrame. Move 3840
1134 End If
1135
1136 InfoImage. Visible = False
1137 ErrImage. Visible = False
1138 QuestImage. Visible = True
1139
1140 res = 0
1141 Call sndPlaySound("Data\Quest. wav", SND_ASYNC + SND_FILENAME + SND_LOOP + SND_APPLICATION)
1142 Show vbModal
1143 QuestMsg = res
1144 Unload Me
1145End Function
1146
1147Private Sub CancelBut_Click()
1148 res = resCancel
1149 Call SoundClick
1150 Hide
1151End Sub
1152
1153Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
1154 Select Case KeyCode
1155 Case 13
1156 Call YesBut_Click
1157 Case 27
1158 Call NoBut_Click
1159 Case 8
1160 If (CancelFrame. Visible = True) Then Call CancelBut_Click
1161 End Select
1162End Sub
1163
1164Private Sub Form_Load()
1165 Call ButEnabled(YesImg, YesBut, True)
1166 Call ButEnabled(CancelImg, CancelBut, True)
1167 Call ButEnabled(NoImg, NoBut, True)
1168End Sub
1169
1170Private Sub NoBut_Click()
1171 res = resNo
1172 Call SoundClick
1173 Hide
1174End Sub
1175
1176Private Sub YesBut_Click()
1177 res = resOk
1178 Call SoundClick
1179 Hide
1180End Sub
1181
Форма: DiagMasterForm. frm
1182Dim DiagData()
1183
1184Private Sub DiagTypeCombo_Click()
1185 DiagTypeImage. Picture = DiagTypeImgs. ListImages(DiagTypeCombo. ListIndex + 1). Picture
1186 Select Case DiagTypeCombo. ListIndex
1187 Case 0, 2: Frame2. Visible = False
1188 Case 1, 3: Frame2. Visible = True

Страницы: 1, 2, 3, 4