Создание базы данных

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