Навигация
MB свободного пространства на жестком диске (плюс файлы баз данных, результирующих HTML и сохраненных в BMP диаграмм)
147393
знака
3
таблицы
0
изображений
1 MB свободного пространства на жестком диске (плюс файлы баз данных, результирующих HTML и сохраненных в BMP диаграмм),
Монитор, поддерживающий режим не менее 800x600x8, желательно 1024x768x24.
Программа DB Xtension состоит из следующих частей:
Основного исполняемого файла DBX. exe
Вспомогательной программы assoc. exe
Набора wav-файлов в папке \Data
Файлы справки в папке \Help, ключевой файл - \Help\index. html
Из-за особенностей реализации Visual Basic также могут потребоваться библиотеки:
asyncfilt. dll
comcat. dll
ctl3d32. dll
msvbvm60. dll
oleaut32. dll
olepro32. dll
stdole. tlb
плюс библиотеки используемых ActiveX-компонентов
3.1.2. Структура программыПрограмма включает в себя следующие файлы:
Формы:
AboutForm. frm (окно О программе)
DiagMasterForm. frm (мастер диаграмм)
DiagResForm. frm (окно построения диаграмм)
EditRecordForm. frm (редакрор записей)
InputForm. frm (окно ввода, замена InputBox)
MainForm. frm (главное окно программы)
MsgForm. frm (окна диалогов, замена MsgBox)
PasswordForm. frm (настройки безопасности и ввод пароля)
QueryMasterForm. frm (мастер запросов)
SelectForm. frm (окно выбора полей или записей)
TableForm. frm (окно создания нового поля)
TextEditForm. frm (редактор текстовых полей)
Модули:
API. bas (объявление и использование функций WinAPI)
DBConst. bas (глобальные описания)
DBTypes. bas (работа с БД как с файлом)
QueryRunner. bas (формирование и выполнение запросов)
Набор графических и аудио файлов
3.1.3. Проверка программы
Для проверки правильности функционирования программы выполните следующие действия:
После запуска программы и появления главной формы Создайте новую БД. В качестве имени укажите «test». Будет создан файл «test. dbx» размером в 13 байт, выведено сообщение, показана пустая таблица на закладке «Главная таблица» и во второе поле строки состояния выведен полный путь к файлу.
Используя мастер запросов добавьте в БД два поля «ФИО» и «Оценка» строкового и числового типа соответственно. Поле значение по умолчанию измените в поле «ФИО» на пустое. Также создайте новую запись.
В таблице появились две колонки с указанными заголовками и запись вида «’’,’0’». Измените значения этого поля на «Иванов И.И. | 4».
Аналогично добавьте записи «Петров П.П. | 5» и «Сидоров С.С. | 3». Должна получится таблица с соответствующими данными.
Используя Выборку на превышение записи по полю «Оценка» более 0 получите копию БД на закладке «Вывод? >0».
Удалите запись с ФИО Петров П.П., воспользовавшись Удалением записи с выбором «1) Петров П.П. – 5». Предупреждение отмените.
В полученной двухстрочной таблице воспользуйтесь Обменом записей. В результате таблица примет вид:
| ФИО | Оценка |
| Сидоров С.С. | 3 |
| Иванов И.И. | 4 |
Закройте созданную таблицу. Отсортируйте по полю ФИО против алфавита. Добавится закладка «Я->А» и таблица «Сидоров, Петров, Иванов».
В мастере запросов из таблицы сортировки выберите поле «Я->А» и тип диаграммы «Колонки». Установите режим 3D. Отрисованная столбчатая диаграмма должна содержать три столбца черного, серого и белого цветов со значениями процентов 25%, 42%, 33%. Сохраните полученную диаграмму в файл «diag. bmp». Одноименный файл будет создан по указанному пути.
Создайте гипертекстовый файл «hiper. html» с заголовком «Тестовый файл». Согласитесь на открытие после создания. Если в вашей системе установлен и зарегистрирован браузер, он будет запущен с содержимым «hiper. html».
Также можно настроить параметры безопасности (Настройки→Защита), сохранить БД на диск и повторно ее открыть для проверки правильности указанных настроек.
Выбор «? - >Помощь» приведет к открытию справки. Если этого не произошло, убедитесь, что выполняется условие запуска браузера с HTML-результатом (пункт X), а также в наличие непосредственно файлов справки.
3.2. Руководство оператора 3.2.1. Общие сведения о программеДанная программа представляет собой удобное средство для работы с однотабличной ненормализованной базой данных. Максимально удобный и функциональный интерфейс облегчает работу с базой данных. Запросная система, позволяющая добавлять, удалять, сортировать, выводить, обменивать и преобразовывать данные, построена на основе нескольких универсальных запросов, охватывающих весь круг конкретных решаемых задач.
3.2.2. Выполнение программыДля запуска программы необходимо запустить DBX. exe.
Для выхода из программы выполните одно из следующих действий:
Выберите Файл→Выход
Нажмите клавишу F12.
Нажмите правую кнопку на панели инструментов главного окна в виде кнопки выключения питания.
Все пункты меню Файл дублируются панелью инструментов в эквивалентном порядке.
Для создания, открытия, сохранения, закрытия и создания копии БД используйте одноименные пункты в меню Файл, либо кнопки на панели инструментов.
Почти вся работа с БД выполняется в Мастере запросов, расположенном в Запросы→Мастер запросов. Возможные запросы:
| Добавление | Поля | Добавление нового поля в таблицу. Параметры задаются в отдельном окне. |
| Записи | Добавление пустой записи (поля заполнены значениями по-умолчанию). | |
| Удаление | Поля | Удаление поля. Настройки удаления в отдельном окне. |
| Записи | Удаление поля. Настройки удаления в отдельном окне. | |
| Сортировка | По алфавиту | Сортировка выбираемого поля в текущей таблице. Все настройки диалогами. |
| Против алфавита | ||
| Выбор | Сравнение с выражением | Выбор тех записей, в которых выбранное поле находится в указанном логическом отношении с введенным значением. |
| Подсчет количества | Выбор тех записей, количество записей в полях в которых находится в указанном логическом отношении с введенным значением. | |
| Обмен | Полей | Перестановка двух выбранных полей. |
| Записей | Перестановка двух выбранных записей. | |
| Смена | Типа поля | Изменение типа поля (число ↔ строка) |
| Заголовка поля | Смена заголовка поля на новое |
Для построения диаграмм выберите Результаты→Мастер диаграмм. Диаграммы можно строить только по полям числового типа.
Для сохранения БД в гипертекстовом формате воспользуйтесь пунктом меню Результаты→Формирование HTML. Достаточно указать путь к файлу и заголовок таблицы.
Для установки защиты выберите Настройки→Защита. Условием защиты по паролю является наличие произвольного, отличного от пробелов текста в поле ввода пароля. Если поле пусто никакие настройки не учитываются.
Для получения справки выберите? →Помощь.
3.2.3. Сообщения оператору (рис.12, рис.13, рис.14)Мастер диаграмм:
Нельзя строить диаграмму по нечисловым данным! (попытка строить диаграмму по строковым значениям)
Редактор записей:
Восстановить поля из БД?
Поля были восстановлены!
Для редактирования чисел редактор не используется. (редактор предназначен лишь для удобства редактирования многострочного текста)
Сохранить поля в БД?
Поля были сохранены в БД!
Изменённое поле перекрывает уже существующее! Измените данные. (измененное поле стало эквивалентно другому полю, либо не было внесено изменений в данные)
Числовое значение превышает разрядную сетку! (введено целое число, большее по модулю 2147483647)
Значение не является целым числом! (введено значение, не являющееся целым числом либо 0)
Строка пуста. Продолжить? (измененная строка пуста)
Мастер запросов:
Запрос отменен!
Список запросов не пуст. Выйти? (были созданы и не выполнены запросы)
Очистить список запросов?
Удалить выбранный запрос из списка?
Запросы выполнены.
Выводить в новую таблицу? Нет для вывода в уже существующую. (запрос может выводить результат либо в уже существующую таблицу, дописывая в конец, либо создать новую)
Не задано относительное значение! (для выполнения запроса недостаточно данных)
Ошибка в запросе! (произошла ошибка во время интерпретации или выполнения запроса)
Добавляемое поле уже существует!
Добавляемый столбец дублируется!
Нельзя добавлять записи в БД без полей! (запись добавляется, а полей в БД еще нет)
В БД нет полей!
В БД нет записей!
Нечего сортировать! (вызвана сортировка пустой БД)
Не с чем сравнивать! (сравнения по пустой БД)
Эквивалентом вывода целочисленного столбца не является целое число! Условие всегда истинно! (в запросе вывода указано строковое значение, а вывод идет по числовому полю)
Добавляемая запись уже существует!
Поле строкового типа преобразуется в числовой тип. Все нечисловые значения будут преобразованы в 0. Продолжить? (при изменении типа поля из строкового в числовое все строки, которые нельзя преобразовать в целые числа, будут заменены 0).
Поле с названием XXX уже существует!
Окно настроек создаваемого поля:
Введенное значение не является целым числом. Преобразовано к '0'.
Главное окно:
Недостаточно прав для выполнения действия! (открыта БД, защищенная паролем, в режиме чтения и производится попытка изменения данных)
Ошибка удаления столбца!
Удалить столбец?
Ошибка удаления записи!
Удалить запись?
БД сохранена!
БД повреждена! (при загрузке БД произошла ошибка)
Пароль принят! (БД, защищенная паролем, открыта с корректно введенным паролем)
Только чтение! (БД, защищенная паролем, открыта в режиме чтения)
Пароль не принят! Доступ запрещён!
БД загружена!
БД создана с настройками по-умолчанию!
литература
1. Microsoft Corporation Microsoft Visual Basic 6.0 Programmer’s Guide, Microsoft Press, 2003 г.
2. 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
1189 End Select
1190End Sub
1191
1192Private Sub Enabled3DCheck_Click()
1193 DimImg. Picture = DiagTypeImgs. ListImages(5 + Enabled3DCheck. value). Picture
1194End Sub
1195
1196Private Sub Form_Load()
1197 Call ButEnabled(OkImg, OkBut, False)
1198 Call ButEnabled(CancelImg, CancelBut, True)
1199 TopImg. Picture = MainForm. TopImageList. ListImages(1). Picture
1200 DiagTypeCombo. ListIndex = 0
1201 DimImg. Picture = DiagTypeImgs. ListImages(5). Picture
1202
1203 TableIndexCombo. Clear
1204 SelectColList. Clear
1205 For i% = 1 To MainForm. TabStrip. Tabs. Count
1206 TableIndexCombo. AddItem MainForm. TabStrip. Tabs(i). Caption
1207 Next i
1208 TableIndexCombo. ListIndex = 0
1209End Sub
1210
1211' по строке "{x, YYY} ZZZ" возвращает номер таблицы (x)
1212Sub GetTableIndex(ByVal str As String, TI As Integer)
1213 s$ = Trim$(Mid$(str, 2, InStr(1, str, ",") - 2))
1214 TI = CInt(s)
1215End Sub
1216
1217' по строке "{x, YYY} ZZZ" и номеру таблицы возвращает номер поля с заголовком ZZZ
1218Sub GetColIndex(ByVal str As String, ByVal TI As Integer, CI As Integer)
1219 s$ = Trim$(Mid$(str, InStr(1, str, "}") + 1))
1220 For i% = 0 To DB(TI). Header. ColCount - 1
1221 If (s = Trim(DB(TI). Cols(i). title)) Then
1222 CI = i
1223 Exit Sub
1224 End If
1225 Next i
1226 CI = - 1 ' событие невозможное но вероятное
1227End Sub
1228
1229Function GettingDiagData(OnlyOneCol As Boolean) As Boolean
1230 GettingDiagData = False
1231
1232 Dim TI As Integer, CI As Integer
1233
1234 Select Case OnlyOneCol
1235 Case True ' ************************************************************************
1236 Call GetTableIndex(SelectColList. List(0), TI)
1237 Call GetColIndex(SelectColList. List(0), TI, CI)
1238 ' зная номер таблицы и номер поля данных нужно проверить тип поля
1239 If (DB(TI). Cols(CI). Class <> ccInteger) Then
1240 Call MsgForm. ErrorMsg("Нельзя строить диаграмму по нечисленным данным! ")
1241 Exit Function
1242 End If
1243 ' заполнение массива данных
1244 ReDim DiagData(2 * DB(TI). Header. RowCount)
1245 For i% = 0 To DB(TI). Header. RowCount - 1
1246 DiagData(2 * i) = DB(TI). Rows(i). Fields(CI)
1247 DiagData(2 * i + 1) = DiagData(2 * i)
1248 Next i
1249 GettingDiagData = True
1250
1251 Case False ' ************************************************************************
1252 ReDim DiagData(2 * SelectColList. ListCount)
1253 For R% = 0 To SelectColList. ListCount - 1
1254 Call GetTableIndex(SelectColList. List(R), TI)
1255 Call GetColIndex(SelectColList. List(R), TI, CI)
1256 ' зная номер таблицы и номер поля данных нужно проверить тип поля
1257 If (DB(TI). Cols(CI). Class <> ccInteger) Then
1258 Call MsgForm. ErrorMsg("Нельзя строить диаграмму по нечисленным данным! ")
1259 Exit Function
1260 End If
1261 Dim Summary As Integer
1262 Summary = 0
1263 For i% = 0 To DB(TI). Header. RowCount - 1
1264 Summary = Summary + DB(TI). Rows(i). Fields(CI)
1265 Next i
1266 ' заполнение массива данных
1267 DiagData(2 * R) = Summary
1268 DiagData(2 * R + 1) = MainForm. TabStrip. Tabs(TI + 1). Caption + ". " + DB(TI). Cols(CI). title
1269 Next R
1270 GettingDiagData = True
1271 End Select
1272
1273End Function
1274
1275Private Sub OkBut_Click()
1276 If (OkBut. Tag = 0) Then Exit Sub
1277 Call SoundClick
1278
1279 If GettingDiagData(SelectColList. ListCount = 1) Then
1280 Load DiagResForm
1281 Call DiagResForm. InitDiagData(DiagData, DiagTypeCombo. ListIndex, (Enabled3DCheck. value = 1))
1282 DiagResForm. Show vbModal
1283 End If
1284End Sub
1285
1286Private Sub CancelBut_Click()
1287 Call SoundClick
1288 Unload Me
1289End Sub
1290
1291Private Sub TableColList_DblClick()
1292 i% = TableColList. ListIndex
1293 s$ = "{ " + CStr(TableIndexCombo. ListIndex) + ", " + TableIndexCombo. Text + " } " + TableColList. List(i)
1294 For j% = 0 To SelectColList. ListCount - 1
1295 If (SelectColList. List(j) = s) Then Exit Sub
1296 Next j
1297 Call ButEnabled(OkImg, OkBut, True)
1298 SelectColList. AddItem s
1299End Sub
1300
1301Private Sub SelectColList_DblClick()
1302 If (SelectColList. ListIndex > - 1) Then SelectColList. RemoveItem SelectColList. ListIndex
1303 Call ButEnabled(OkImg, OkBut, (SelectColList. ListCount > 0))
1304End Sub
1305
1306Private Sub TableIndexCombo_Click()
1307 DBI% = TableIndexCombo. ListIndex
1308 TableColList. Clear
1309 For i% = 0 To DB(DBI). Header. ColCount - 1
1310 TableColList. AddItem DB(DBI). Cols(i). title
1311 Next i
1312 If (TableColList. ListCount > 0) Then TableColList. ListIndex = 0
1313End Sub
Форма: PasswordForm. frm
1314Public res As Boolean
1315
1316Private Sub Form_Activate()
1317 res = False
1318 If Frame1. Visible Then
1319 PassText. SetFocus
1320 Else
1321 SetPassText. SetFocus
1322 End If
1323End Sub
1324
1325Private Sub Form_Load()
1326 Call ButEnabled(OkImg, OkBut, True)
1327 Call ButEnabled(CancelImg, CancelBut, True)
1328 TopImg. Picture = MainForm. TopImageList. ListImages(1). Picture
1329End Sub
1330
1331Private Sub OkBut_Click()
1332 res = True
1333 Call SoundClick
1334 Hide
1335End Sub
1336
1337Private Sub CancelBut_Click()
1338 Call SoundClick
1339 Hide
1340End Sub
1341
1342Private Sub PassText_KeyDown(KeyCode As Integer, Shift As Integer)
1343 If (KeyCode = 13) Then Call OkBut_Click
1344End Sub
1345
1346Private Sub SetPassText_KeyDown(KeyCode As Integer, Shift As Integer)
1347 If (KeyCode = 13) Then Call OkBut_Click
1348End Sub
Форма: AboutForm. frm
1349Private Sub Form_Load()
1350 Call MInit
1351 Call ButEnabled(OkImg, OkBut, True)
1352 Label6. Caption = "v. " + CStr(App. Major) + ". " + CStr(App. Minor) + ". " + CStr(App. Revision)
1353End Sub
1354
1355Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
1356 Call MDown(x, y)
1357End Sub
1358
1359Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
1360 Call MMove(hwnd, x, y)
1361End Sub
1362
1363Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
1364 Call MUp
1365End Sub
1366
1367Private Sub Image2_Click()
1368 Call ShellExecute(0, "", "mailto: xerx@nightmail. ru", "", "", 1)
1369End Sub
1370
1371Private Sub NoViewLabel_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
1372 Call MDown(x, y)
1373End Sub
1374
1375Private Sub NoViewLabel_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
1376 Call MMove(hwnd, x, y)
1377End Sub
1378
1379Private Sub NoViewLabel_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
1380 Call MUp
1381End Sub
1382
1383Private Sub OkBut_Click()
1384 Unload Me
1385End Sub
Форма: DiagResForm. frm
1386Dim dW%, dH%, dX%, dH2%
1387Dim DiagData() As TDiagElem
1388Dim DrawingMode As Byte, Use3D As Boolean
1389
1390' константы для вывода куска более 270 градусов (выводимая часть)
1391Const mode270begin As Byte = 1
1392Const mode270end As Byte = 2
1393
1394' данные для процедур рисования
1395 Const Pi_180 As Double = 1.74532925199433E-02
1396 Const Pi_2 As Double = 1.5707963267949
1397 Const NearZero As Double = 1E-45
1398
1399 Dim Xc%, Yc% ' центр диаграммы
1400 Dim Radius# ' радиус кусков
1401 Dim InRad# ' радиус разноса кусков
1402 Dim OneGradus# ' единиц в одном градусе
1403 Dim ChartHeight% ' высота графика
1404 Dim ChartWidth% ' ширина графика
1405 Dim ChartTop% ' верх графика
1406 Dim ChartDown% ' низ графика
1407 Dim ItemCount% ' кол-во элементов
1408 Dim Max%, Sum% ' максимальное значение и сумма всех значений
1409 Dim OldGrad# ' предыдущий угол
1410 Dim LineCount As Long ' количество полос заливки
1411 Dim d3D% ' смещение в 3D, в пикселях
1412 Dim dWidth As Single ' ширина одного столбца
1413 Dim dHeight As Single ' высота 'единицы высоты'
1414 Dim StartFillColor As Long
1415 Dim EndFillColor As Long
1416 Dim LineColor As Long
1417 Dim LineWidth As Byte
1418 Dim PointRadius%
1419 Dim Ellipce#
1420 Dim UseColorFill As Boolean
1421 Dim UseCircleLegend As Boolean
1422 Dim UseLineLeftValues As Boolean
1423
1424Public Sub InitDiagData(Data(), ByVal Mode As Byte, ByVal May3D As Boolean)
1425 ReDim DiagData(UBound(Data) \ 2 - 1)
1426 d# = 255 / (UBound(Data) \ 2 - 1)
1427 For i% = 0 To (UBound(Data) \ 2 - 1)
1428 DiagData(i). Val = Abs(Data(2 * i))
1429 DiagData(i). Text = Data(2 * i + 1)
1430 DiagData(i). Color = RGB(i * d, i * d, i * d)
1431 Next i
1432 DrawingMode = Mode
1433 Use3D = May3D
1434
1435 Label2. Visible = (DrawingMode <> 3)
1436 Label3. Visible = Label2. Visible
1437 VScroll. Enabled = Not Label2. Visible
1438End Sub
1439
1440Public Sub ColorFill(PB As PictureBox, ByVal StColor As Long, ByVal EnColor As Long)
1441 Dim dR#, dG#, DB#, dC1 As Long, dC2 As Long
1442 Dim R#, G#, B#
1443 Dim intLoop As Long
1444
1445 PB. Line (0, 0) - (PB. Width, PB. Height), EnColor, BF
1446
1447 ' get Red
1448 dC1 = StColor - (StColor \ &H100) * &H100
1449 R = dC1
1450 dC2 = EnColor - (EnColor \ &H100) * &H100
1451 dR = (dC1 - dC2) / LineCount
1452
1453 ' get Green
1454 dC1 = (StColor - (StColor \ &H10000) * &H10000 - dC1) \ &H100
1455 G = dC1
1456 dC2 = (EnColor - (EnColor \ &H10000) * &H10000 - dC2) \ &H100
1457 dG = (dC1 - dC2) / LineCount
1458
1459 ' get Blue
1460 dC1 = StColor \ &H10000
1461 B = dC1
1462 dC2 = EnColor \ &H10000
1463 DB = (dC1 - dC2) / LineCount
1464
1465 With PB
1466. DrawStyle = 1
1467. DrawMode = vbCopyPen
1468. ScaleMode = vbPixels
1469. DrawWidth = 2
1470. ScaleHeight = LineCount
1471 For intLoop = 0 To LineCount - 1
1472 PB. Line (0, intLoop) - (PB. Width, intLoop - 1), RGB(R, G, B), BF
1473 R = R - dR: If (R < 0) Then R = 255: If (R > 255) Then R = 0
1474 G = G - dG: If (G < 0) Then G = 255: If (G > 255) Then G = 0
1475 B = B - DB: If (B < 0) Then B = 255: If (B > 255) Then B = 0
1476 Next intLoop
1477. ScaleMode = vbTwips
1478. DrawWidth = 1
1479 End With
1480End Sub
1481
1482Sub OutOneElem(ElemIndex As Integer, StAn#, EnAn#, Optional Mode270Mode As Byte = 0)
1483 ' центральный угол
1484 angle# = (StAn + (EnAn - StAn) / 2) * Pi_180
1485
1486 ' динамическая глубина
1487 d3D_% = Round(d3D / 100 * (100 - Round(100 * Ellipce)))
1488 If (d3D_ = 0) Then d3D_ = 1
1489 ' динамическое смещение центров кусков
1490 r_# = Ellipce * d3D / 100
1491
1492 X1# = Xc + Radius * Cos(angle)
1493 Y1# = Yc - Radius * Sin(angle)
1494
1495 x# = Xc + InRad / Radius * (X1 - Xc)
1496 y# = Yc + InRad / Radius * (Y1 - Yc) * r_
1497
1498 If (Not Use3D) Then
1499 Chart. FillStyle = 0
1500 Chart. FillColor = DiagData(ElemIndex). Color
1501 If (StAn <> 0) Then
1502 Chart. Circle (x, y), Radius, LineColor, - StAn * Pi_180, - EnAn * Pi_180, Ellipce
1503 Else
1504 Chart. Circle (x, y), Radius, LineColor, - 1E-45, - EnAn * Pi_180, Ellipce
1505 End If
1506 Chart. FillStyle = 1
1507
1508 ' вывод значений
1509 R# = 1.3. * Radius
1510 X2# = x + R * Cos(angle)
1511 Y2# = y - Ellipce * R * Sin(angle)
1512
1513 x0# = x + Radius * Cos(angle)
1514 y0# = y - Ellipce * Radius * Sin(angle)
1515
1516 str_1$ = CStr(DiagData(ElemIndex). Text)
1517 d1# = Chart. TextWidth(str_1)
1518 str_2$ = CStr(DiagData(ElemIndex). Val)
1519 d2# = Chart. TextWidth(str_2)
1520
1521 If UseCircleLegend Then
1522 Chart. DrawStyle = 4
1523 Chart. Line (x0, y0) - (X2, Y2), LineColor
1524 Chart. DrawStyle = 0
1525
1526 If Not ((angle > Pi_2) And (angle <= 3 * Pi_2)) Then
1527 Chart. Line (X2, Y2) - (X2 + d1, Y2), LineColor
1528 Chart. CurrentX = X2
1529 Chart. CurrentY = Y2
1530 Chart. Print CStr(str_1)
1531
1532 Chart. CurrentX = X2
1533 Chart. CurrentY = Y2 - Chart. TextHeight(str_2)
1534 Chart. Print CStr(str_2)
1535 Else
1536 Chart. Line (X2, Y2) - (X2 - d1, Y2), LineColor
1537 Chart. CurrentX = X2 - d1
1538 Chart. CurrentY = Y2
1539 Chart. Print CStr(str_1)
1540
1541 Chart. CurrentX = X2 - d1
1542 Chart. CurrentY = Y2 - Chart. TextHeight(str_2)
1543 Chart. Print CStr(str_2)
1544 End If
1545 End If
1546
1547 Else
1548 Chart. FillStyle = 0
1549 Chart. FillColor = DiagData(ElemIndex). Color
1550
1551 Select Case Mode270Mode
1552 Case 0
1553 sa# = StAn
1554 If (sa = 0) Then sa = 1E-45 Else sa = sa * Pi_180
1555 For i% = d3D_ To 1 Step - 1
1556 If (i = d3D_) Then
1557 Chart. DrawStyle = vbSolid
1558 Chart. Circle (x, Screen. TwipsPerPixelY * (i - 1) + y), Radius, LineColor, - sa, - EnAn * Pi_180, Ellipce
1559 Chart. DrawStyle = vbInvisible
1560 ElseIf (i = 1) Then
1561 Chart. DrawStyle = vbSolid
1562 Chart. Circle (x, y), Radius, LineColor, - sa, - EnAn * Pi_180, Ellipce
1563 Chart. DrawStyle = vbInvisible
1564 Else
1565 Chart. Circle (x, Screen. TwipsPerPixelY * (i - 1) + y), Radius, LineColor, - sa, - EnAn * Pi_180, Ellipce
1566 End If
1567 Next i
1568
1569 Case mode270begin
1570 For i% = d3D_ To 1 Step - 1
1571 If (i = d3D_) Then
1572 Chart. DrawStyle = vbSolid
1573 Chart. Circle (x, Screen. TwipsPerPixelY * (i - 1) + y), Radius, LineColor, - StAn * Pi_180, - EnAn * Pi_180, Ellipce
1574 Chart. DrawStyle = vbInvisible
1575 Else
1576 Chart. Circle (x, Screen. TwipsPerPixelY * (i - 1) + y), Radius, LineColor, - StAn * Pi_180, - angle, Ellipce
1577 End If
1578 Next i
1579
1580 Case mode270end
1581 For i% = d3D_ To 1 Step - 1
1582 If (i = 1) Then
1583 Chart. DrawStyle = vbSolid
1584 Chart. Circle (x, y), Radius, LineColor, - StAn * Pi_180, - EnAn * Pi_180, Ellipce
1585 Else
1586 Chart. DrawStyle = vbInvisible
1587 Chart. Circle (x, Screen. TwipsPerPixelY * (i - 1) + y), Radius, LineColor, - angle, - EnAn * Pi_180, Ellipce
1588 End If
1589 Next i
1590 End Select
1591
1592 Chart. FillStyle = 1
1593 Chart. DrawStyle = vbSolid
1594
1595 ' вывод значений
1596 R# = 1.3. * Radius
1597 X2# = x + R * Cos(angle)
1598 Y2# = y - Ellipce * R * Sin(angle)
1599
1600 x0# = x + Radius * Cos(angle)
1601 y0# = y - Ellipce * Radius * Sin(angle)
1602
1603 str_1$ = CStr(DiagData(ElemIndex). Text)
1604 d1# = Chart. TextWidth(str_1)
1605 str_2$ = CStr(DiagData(ElemIndex). Val)
1606 d2# = Chart. TextWidth(str_2)
1607
1608 If UseCircleLegend Then
1609 Chart. DrawStyle = 4
1610 Chart. Line (x0, y0) - (X2, Y2), LineColor
1611 Chart. DrawStyle = 0
1612
1613 If Not ((angle > Pi_2) And (angle <= 3 * Pi_2)) Then
1614 Chart. Line (X2, Y2) - (X2 + d1, Y2), LineColor
1615 Chart. CurrentX = X2
1616 Chart. CurrentY = Y2
1617 Chart. Print CStr(str_1)
1618
1619 Chart. CurrentX = X2
1620 Chart. CurrentY = Y2 - Chart. TextHeight(str_2)
1621 Chart. Print CStr(str_2)
1622 Else
1623 Chart. Line (X2, Y2) - (X2 - d1, Y2), LineColor
1624 Chart. CurrentX = X2 - d1
1625 Chart. CurrentY = Y2
1626 Chart. Print CStr(str_1)
1627
1628 Chart. CurrentX = X2 - d1
1629 Chart. CurrentY = Y2 - Chart. TextHeight(str_2)
1630 Chart. Print CStr(str_2)
1631 End If
1632 End If
1633
1634 ' а теперь вывод боковых линий
1635 Chart. DrawStyle = 0
1636
1637 ' начальный угол
1638 If Not ((StAn > 90) And (StAn < 180)) Then
1639 sa# = StAn * Pi_180
1640 x0 = x + Radius * Cos(sa)
1641 y0 = y - Radius * Ellipce * Sin(sa)
1642
1643 If (Mode270Mode <> mode270end) Then
1644 Chart. Line (x0, y0) - (x0, y0 + d3D_ * Screen. TwipsPerPixelY), LineColor
1645 End If
1646 End If
1647
1648 ' конечный угол
1649 If Not ((EnAn > 0) And (EnAn < 90)) Then
1650 x0 = x + Radius * Cos(EnAn * Pi_180)
1651 y0 = y - Radius * Ellipce * Sin(EnAn * Pi_180)
1652
1653 Chart. Line (x0, y0) - (x0, y0 + d3D_ * Screen. TwipsPerPixelY), LineColor
1654 End If
1655
1656 ' центр
1657 If Not ((EnAn >= 270) And (StAn <= 270)) Then
1658 Chart. Line (x, y) - (x, y + d3D_ * Screen. TwipsPerPixelY), LineColor
1659 End If
1660
1661 ' левый край
1662 If ((StAn <= 180) And (EnAn >= 180)) Then
1663 Chart. Line (x - Radius, y) - (x - Radius, y + d3D_ * Screen. TwipsPerPixelY), LineColor
1664 End If
1665
1666 End If
1667
1668 OldGrad = Grad
1669End Sub
1670
1671
1672' рисование круговой диаграммы
1673Sub DrawCircle()
1674 Dim Mode270 As Boolean
1675 Dim Item270%
1676
1677 ItemCount = UBound(DiagData) + 1
1678
1679 With Chart
1680 Max = - 1
1681 Sum = 0
1682 For i% = 1 To ItemCount
1683 If (DiagData(i - 1). Val > Max) Then Max = DiagData(i - 1). Val
1684 Sum = Sum + DiagData(i - 1). Val
1685 Next i
1686
1687 Mode270 = (Max > 3 / 4 * Sum)
1688
1689 OneGradus = 360 / Sum
1690 OldGrad = 0.00001
1691
1692 Xc = Chart. Width \ 2
1693 Yc = Chart. Height \ 2
1694
1695 Dim pos90%, pos270% ' индексы ключевых элементов
1696 pos90 = - 1
1697 pos270 = - 1
1698 OldGrad = 0
1699
1700 Dim Angles() As Double
1701 ReDim Angles(ItemCount - 1, 1)
1702
1703 For i% = 1 To ItemCount
1704 If Mode270 Then If (DiagData(i - 1). Val = Max) Then Item270 = i - 1
1705 Grad# = DiagData(i - 1). Val * OneGradus + OldGrad
1706 If (OldGrad <= 90) And (Grad >= 90) Then pos90 = i - 1
1707 If (OldGrad <= 270) And (Grad >= 270) Then pos270 = i - 1
1708 Angles(i - 1, 0) = OldGrad
1709 Angles(i - 1, 1) = Grad
1710 OldGrad = Grad
1711 Next i
1712
1713 Chart. DrawStyle = 0
1714
1715 If Not Mode270 Then
1716
1717 For i% = pos90 To 0 Step - 1
1718 Call OutOneElem(i, Angles(i, 0), Angles(i, 1))
1719 Next i
1720
1721 For i% = pos90 + 1 To pos270 - 1
1722 Call OutOneElem(i, Angles(i, 0), Angles(i, 1))
1723 Next i
1724
1725 For i% = ItemCount - 1 To pos270 Step - 1
1726 Call OutOneElem(i, Angles(i, 0), Angles(i, 1))
1727 Next i
1728 Else
1729
1730 i% = pos90 - 1
1731 If (i < 0) Then i = ItemCount - 1
1732
1733 Call OutOneElem(Item270, Angles(Item270, 0), Angles(Item270, 1), mode270begin)
1734
1735 Do While (i <> Item270)
1736 Call OutOneElem(i, Angles(i, 0), Angles(i, 1))
1737
1738 i = i - 1
1739 If (i < 0) Then i = ItemCount - 1
1740 Loop
1741
1742 Call OutOneElem(Item270, Angles(Item270, 0), Angles(Item270, 1), mode270end)
1743
1744 End If
1745 End With
1746End Sub
1747
1748' рисование линейной, точечной и столбчатой диаграмм
1749Sub DrawPoint()
1750 Dim d3DX%
1751 Dim d3DY%
1752 Dim OldX%, OldY% ' координаты предыдущей точки
1753
1754 ItemCount = UBound(DiagData) + 1
1755 ChartHeight = Chart. Height * 0.8
1756 ChartTop = Chart. Height * 0.1
1757 ChartDown = Chart. Height * 0.9
1758
1759 With Chart
1760 dWidth = Chart. Width / (2 * ItemCount + 1)
1761
1762 Max = - 1
1763 Sum = 0
1764 For i% = 1 To ItemCount
1765 If (DiagData(i - 1). Val > Max) Then Max = DiagData(i - 1). Val
1766 Sum = Sum + DiagData(i - 1). Val
1767 Next i
1768
1769 dHeight = ChartHeight / Max
1770
1771 d3DX = Screen. TwipsPerPixelX
1772 d3DY = Screen. TwipsPerPixelY
1773
1774 With Chart
1775. DrawWidth = 1
1776. DrawStyle = 3
1777 Chart. Line (dWidth * 0.9, ChartTop \ 2) - (dWidth * 0.9, ChartDown), LineColor
1778 Chart. Line (dWidth * 0.9, ChartDown) - ((2 * ItemCount + 0.5) * dWidth, ChartDown), LineColor
1779. DrawStyle = 0
1780
1781. FontSize =. FontSize + 3
1782. FontUnderline = True
1783
1784. CurrentX = 2 * d3DX
1785. CurrentY = 2 * d3DY
1786 Chart. Print "Значения"
1787
1788 str_$ = "Подписи"
1789. CurrentX =. Width - . TextWidth(str_) - 10 * d3DX
1790. CurrentY = ChartDown +. TextHeight(str_)
1791 Chart. Print str_
1792
1793. FontSize =. FontSize - 3
1794. FontUnderline = False
1795 End With
1796
1797
1798 For i% = 1 To ItemCount
1799 j% = 2 * i - 1
1800 Dim y#, x#
1801 y = ChartTop + dHeight * (Max - DiagData(i - 1). Val)
1802
1803 Select Case DrawingMode
1804 Case 0 ' // // // // // // // // // // // // // // // // / ЛИНИИ // // // // // // // // // // // // // // // // // // // // /
1805 x# = (j + 0.5) * dWidth
1806
1807 If (i > 1) Then
1808 Chart. DrawWidth = LineWidth
1809 Chart. Line (OldX, OldY) - (x, y), DiagData(i - 1). Color
1810 Chart. DrawWidth = 1
1811 End If
1812 Chart. DrawStyle = 1
1813 Chart. Line (x, y) - (x, ChartDown), DiagData(i - 1). Color
1814 Chart. DrawStyle = 0
1815 OldX = x
1816 OldY = y
1817
1818 str_$ = CStr(DiagData(i - 1). Text)
1819 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1820 Chart. CurrentY = ChartDown + Chart. TextHeight(str_) \ 10
1821 Chart. Print str_
1822
1823 str_ = CStr(Round(DiagData(i - 1). Val / Sum * 100)) + "%"
1824 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1825 Chart. CurrentY = y - Chart. TextHeight(str_) * 1.2
1826 Chart. Print str_
1827
1828 ' значение слева с засечкой и линией
1829 str_ = CStr(DiagData(i - 1). Val)
1830 If UseLineLeftValues Then
1831 Chart. CurrentX = dWidth * 0.8 - Chart. TextWidth(str_)
1832 Chart. DrawStyle = 2
1833 Chart. Line (dWidth * 0.9, y) - (x, y), LineColor
1834 Chart. DrawStyle = 0
1835 End If
1836
1837 Chart. DrawWidth = 2
1838 Chart. Line (dWidth * 0.85, y) - (dWidth * 0.95, y), LineColor
1839 Chart. DrawWidth = 1
1840 x# = dWidth * 0.8 - Chart. TextWidth(str_)
1841 Chart. CurrentX = x
1842 Chart. CurrentY = y - Chart. TextHeight(str_) \ 2
1843 Chart. Print str_
1844
1845 Case 1 ' // // // // // // // // // // // // // // // // / КОЛОНКИ // // // // // // // // // // // // // // // // // // // /
1846 If (Not Use3D) Then
1847 Chart. Line (j * dWidth, y) - ((j + 1) * dWidth, ChartDown), DiagData(i - 1). Color, BF
1848 Chart. Line (j * dWidth, y) - ((j + 1) * dWidth, ChartDown), LineColor, B
1849
1850 str_ = CStr(DiagData(i - 1). Text)
1851 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1852 Chart. CurrentY = ChartDown + Chart. TextHeight(str_) \ 10
1853 Chart. Print str_
1854
1855 str_ = CStr(Round(DiagData(i - 1). Val / Sum * 100)) + "%"
1856 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1857 Chart. CurrentY = y - Chart. TextHeight(str_) * 1.2
1858 Chart. Print str_
1859
1860 ' значение слева с засечкой и линией
1861 str_ = CStr(DiagData(i - 1). Val)
1862 If UseLineLeftValues Then
1863 Chart. CurrentX = dWidth * 0.8 - Chart. TextWidth(str_)
1864 Chart. DrawStyle = 2
1865 Chart. Line (dWidth * 0.9, y) - (j * dWidth, y), LineColor
1866 Chart. DrawStyle = 0
1867 End If
1868
1869 x# = dWidth * 0.8 - Chart. TextWidth(str_)
1870 Chart. CurrentX = x
1871 Chart. CurrentY = y - Chart. TextHeight(str_) \ 2
1872 Chart. Print str_
1873 Chart. CurrentX = x
1874 Chart. CurrentY = y
1875 Chart. DrawWidth = 2
1876 Chart. Line (dWidth * 0.85, y) - (dWidth * 0.95, y), LineColor
1877 Chart. DrawWidth = 1
1878 Else
1879 For k% = 0 To d3D - 1
1880 Chart. Line (j * dWidth + k * d3DX, y - k * d3DY) - ((j + 1) * dWidth + k * d3DX, ChartDown - k * d3DY), DiagData(i - 1). Color, B
1881 Next k
1882 Chart. Line (j * dWidth, y) - ((j + 1) * dWidth, ChartDown), DiagData(i - 1). Color, BF
1883 ' верхняя левая в глубине
1884 ltdx% = j * dWidth + (d3D - 1) * d3DX
1885 ltdy% = y - (d3D - 1) * d3DY
1886 ' верхняя правая в глубине
1887 rtdx% = (j + 1) * dWidth + (d3D - 1) * d3DX
1888 rtdy% = y - (d3D - 1) * d3DY
1889 ' нижняя правая в глубине
1890 rddx% = (j + 1) * dWidth + (d3D - 1) * d3DX
1891 rddy% = ChartDown - (d3D - 1) * d3DY
1892 ' верхняя в глубине
1893 Chart. Line (rtdx, rtdy) - (rddx, rddy), LineColor
1894 ' правая в глубине
1895 Chart. Line (ltdx, ltdy) - (rtdx, rtdy), LineColor
1896
1897 ' левая переходная
1898 Chart. Line (ltdx, ltdy) - (ltdx - d3D * d3DX, ltdy + d3D * d3DY), LineColor
1899 ' правая верхняя переходная
1900 Chart. Line (rtdx, rtdy) - (rtdx - d3D * d3DX, rtdy + d3D * d3DY), LineColor
1901 ' правая нижняя переходная
1902 Chart. Line (rddx, rddy) - (rddx - d3D * d3DX, rddy + d3D * d3DY), LineColor
1903 Chart. Line (j * dWidth, y) - ((j + 1) * dWidth, ChartDown), LineColor, B
1904
1905 ' надпись внизу
1906 str_ = CStr(DiagData(i - 1). Text)
1907 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1908 Chart. CurrentY = ChartDown + Chart. TextHeight(str_) \ 10
1909 Chart. Print str_
1910 ' процент вверху
1911 str_ = CStr(Round(DiagData(i - 1). Val / Sum * 100)) + "%"
1912 Chart. CurrentX = d3D * d3DX + j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1913 Chart. CurrentY = y - d3D * d3DY - Chart. TextHeight(str_) * 1.2
1914 Chart. Print str_
1915 ' значение слева с засечкой и линией
1916 str_ = CStr(DiagData(i - 1). Val)
1917 If UseLineLeftValues Then
1918 Chart. CurrentX = dWidth * 0.8 - Chart. TextWidth(str_)
1919 Chart. DrawStyle = 2
1920 Chart. Line (dWidth * 0.9, y) - (j * dWidth, y), LineColor
1921 Chart. DrawStyle = 0
1922 End If
1923
1924 x# = dWidth * 0.8 - Chart. TextWidth(str_)
1925 Chart. CurrentX = x
1926 Chart. CurrentY = y - Chart. TextHeight(str_) \ 2
1927 Chart. Print str_
1928 Chart. CurrentX = x
1929 Chart. CurrentY = y
1930 Chart. DrawWidth = 2
1931 Chart. Line (dWidth * 0.85, y) - (dWidth * 0.95, y), LineColor
1932 Chart. DrawWidth = 1
1933 End If
1934
1935 Case 2 ' // // // // // // // // // // // // // // // // / ТОЧКИ // // // // // // // // // // // // // // // // // // // // /
1936 Chart. FillStyle = 0
1937 Chart. FillColor = DiagData(i - 1). Color
1938 x# = (j + 0.5) * dWidth
1939 Chart. Circle (x, y), PointRadius * d3DX, LineColor
1940 Chart. FillStyle = 1
1941 Chart. DrawStyle = 1
1942 Chart. Line (x, y) - (x, ChartDown), DiagData(i - 1). Color
1943 Chart. DrawStyle = 0
1944
1945 str_ = CStr(DiagData(i - 1). Text)
1946 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1947 Chart. CurrentY = ChartDown + Chart. TextHeight(str_) \ 10
1948 Chart. Print str_
1949
1950 str_ = CStr(Round(DiagData(i - 1). Val / Sum * 100)) + "%"
1951 Chart. CurrentX = j * dWidth + (dWidth - Chart. TextWidth(str_)) \ 2
1952 Chart. CurrentY = y - PointRadius * d3D - Chart. TextHeight(str_) * 1.2
1953 Chart. Print str_
1954
1955 ' значение слева с засечкой и линией
1956 str_ = CStr(DiagData(i - 1). Val)
1957 Chart. CurrentX = dWidth * 0.8 - Chart. TextWidth(str_)
1958 Chart. DrawStyle = 2
1959 Chart. Line (dWidth * 0.9, y) - (x, y), LineColor
1960 Chart. DrawStyle = 0
1961
1962 Chart. DrawWidth = 2
1963 Chart. Line (dWidth * 0.85, y) - (dWidth * 0.95, y), LineColor
1964 Chart. DrawWidth = 1
1965 x# = dWidth * 0.8 - Chart. TextWidth(str_)
1966 Chart. CurrentX = x
1967 Chart. CurrentY = y - Chart. TextHeight(str_) \ 2
1968 Chart. Print str_
1969 End Select
1970 Next i
1971
1972 End With
1973End Sub
1974
1975Sub DrawDiagram()
1976 If (Chart. Height > Screen. TwipsPerPixelX * 5) And (UseColorFill) Then
1977 Call ColorFill(Chart, StartFillColor, EndFillColor)
1978 Else
1979 Chart. Line (0, 0) - (Chart. Width, Chart. Height), StartFillColor, BF
1980 End If
1981
1982 Select Case DrawingMode
1983 Case 3: Call DrawCircle
1984 Case Else: Call DrawPoint
1985 End Select
1986End Sub
1987
1988Private Sub Chart_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
1989 If (DrawingMode <> 3) Then
1990 y = Round((ChartDown - y) * Max / (ChartDown - ChartTop))
1991 Label3. Caption = CStr(y)
1992 End If
1993End Sub
1994
1995Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
1996 If (KeyCode = vbKeyF5) Then Call DrawDiagram
1997End Sub
1998
1999Private Sub Form_Load()
2000 dW = Width - Chart. Width
2001 dH = Height - Chart. Height
2002 dX = Width - VScroll. Left
2003 dH2 = Height - VScroll. Height
2004 DrawingMode = 0
2005 Use3D = False
2006 LineCount = 100
2007 d3D = 15
2008 StartFillColor = RGB(255, 255, 128)
2009 EndFillColor = RGB(0, 128, 255)
2010 LineColor = 0
2011 LineWidth = 1
2012 Ellipce = 2 / 5
2013 PointRadius = 15
2014
2015 UseColorFill = True
2016 UseCircleLegend = True
2017 UseLineLeftValues = True
2018
2019 ChartHeight = Chart. Height * 0.85
2020 ChartWidth = Chart. Width * 0.85
2021 ChartTop = Chart. Height * 0.075
2022 ChartDown = Chart. Height * 0.925
2023 If (ChartWidth < ChartHeight) Then Radius = ChartWidth Else Radius = ChartHeight
2024 Radius = Radius * 0.5
2025 InRad = 0.1 * Radius
2026End Sub
2027
2028Private Sub Form_Resize()
2029 Min% = Width - dW + 5 * Screen. TwipsPerPixelX
2030 If (Min < 0) Then Min = 0
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
Похожие работы
... или отменить редактирования записи. При выборе пункта 4 на экран выведутся все записи. Упорядочивание по алфавиту происходит автоматически при создании, удалении или редактировании записи. При выборе пятого пункта пользователю предлагается сначала выбрать тип вместимости стадионов (равно, больше, меньше, больше или равно, меньше или равно), затем ввести вместимость, по которой хотите ...
... int(11)); mysql> DESCRIBE pokup; mysql> CREATE TABLE sale (cod_s int(11), cost_s float, date_s date, cod_pokup int(11), cod_prodav int(11)); mysql> DESCRIBE sale; Посмотрим список созданных таблиц mysql> SHOW TABLES; Вводим данные в таблицы. Сначала заполним таблицу sale mysql> INSERT INTO sale -> VALUES (3003, 767, "2005-03-04", 2001, 1001); ...
... за счет доменов прямо пропорционально количеству полей всех таблиц. Поэтому, обычно создают достаточное количество доменов для описания таблиц в БД, а потом создают сами таблицы. Вот выдержка из реальной базы данных для создания доменов: CREATE DOMAIN IZMER_NUM INTEGER NOT NULL; CREATE DOMAIN ACTIVITIES_NUM INTEGER NOT NULL; . . . CREATE DOMAIN NAMES_TYPE VARCHAR(45) COLLATE PXW_CYRL; CREATE ...
... Мягкий 31.07.2006 240 Познавательная Внешним ключом таблицы является поле Автор. Структуры созданных таблиц выглядят следующим образом: Структура таблицы «Авторы» созданной базы данных «Картотека книг» Имя поля Тип данных Описание КодАвтора Счетчик Отражает числовое значение кода авторов книг Имя Текстовый (10) Имя автора Фамилия Текстовый (20) Фамилия автора ...
0 комментариев