Для сохранения БД в гипертекстовом формате воспользуйтесь пунктом меню Результаты→Формирование 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%

11Private Sub AboutProg_Click()

12 CoolTimer. Enabled = False

13 AboutForm. Show vbModal

14 CoolTimer. Enabled = True

15End Sub

17Private Sub CloseDB_Click()

18 CoolTimer. Enabled = False

20 If DBChanged Then

21 If (MsgForm. QuestMsg("В БД внесены не сохранённые изменения. Закрыть не сохраняя? ") <> resOk) Then GoTo exit_

22 End If

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)

31exit_:

33 CoolTimer. Enabled = True

34End Sub

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

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

53Sub CoolMouseMove(Index%)

54 If (Index = OldImageIndex) Then Exit Sub

55 Call DisEnImage(Index, 2)

56 Call RetImage

57 OldImageIndex = Index

58End Sub

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

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

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

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