Курсовая работа: Создание базы данных

Данный курсовой проект представляет собой программу, предназначенную для работы с однотабличной ненормализованной базой данных. Основной целью программы является обеспечение инструментарием для работы с базой данных различных школьных соревнований. Предоставляемый инструментарий позволяет работать с БД на физическом и логическом уровнях. Физический уровень, меняющий структуру БД, позволяет работать с отдельными БД, создавать, удалять и обменивать поля и записи, а также менять типы полей БД. На логическом уровне можно менять значения полей (заголовки) и записей, производить выборки, сортировки, строить различные диаграммы, сохранять БД в гипертекстовом формате. Для облегчения работы с программой написана подробнейшая справка в HTML.

1. исследовательская часть

1.1. Постановка задачи

Используя средства языка программирования создать файл, элементами которого являются записи, определенные таблицей вашего варианта.

Создать файл из 10 – 15 записей. Предусмотреть возможность редактирования файловой информации (добавление, удаление, замену всей записи и одного из полей записи).

Создать запросы, согласно вашему варианту.

Разработать интерфейс пользователя для реализации выше перечисленных функций.

Создать файл справочной службы и подключить его к интерфейсу.

Подготовить расчетно-пояснительную записку (см. методические указания).

Основные алгоритмы работы программы вынести на лист А1.

Создать заставку-презентацию данного программного продукта с использованием графических средств VB.

Карточка участника соревнования.

Фамилия

Имя

Отчество

Год рождения

Дата

Соревнования

Вид состязания

Показатели в состязании

Школа

Район

Добавляемый столбец.

Запросы:

сколько участников соревнований состязалось в прыжках в длину; какой показатель является лучшим в этом виде состязаний?

получить список учащихся школы № 20, принявших участие в соревнованиях;

сколько участников Ленинского района приняли участие в соревнованиях?

каков наилучший показатель в прыжках в высоту, кто установил рекорд?

получить список участников соревнований, принявших участие более, чем в трех видах состязаний.

Добавляемый столбец «Фамилия, Имя, Отчество тренера».

Дополнительные запросы:

какое количество участников состязаний подготовил тренер Сидоров И. И.;

получить фамилию, Имя, Отчество тренера, подготовившего участника с лучшими показателями в толкании ядра.

1.2. Общие сведения

Visual Basic является прямым потомком языка Basic, создававшегося как очень простой язык для обучения основам программирования. С тех пор язык значительно расширился, а с появлением Visual Basic стал поддерживать концепцию ООП. Однако он всё-таки ещё слишком прост, и не приспособлен к написанию широкого круга программ. С другой стороны, он вполне подходит для своей основной цели – написанию офисных приложений. Благодаря простоте и склонности к офисным приложениям диалект Visual Basic VBA (Visual Basic for Application) сделан внутренним языком для приложений Microsoft Office, а также в сторонних программах, имеющих лицензию на использование языка. Также существует скриптовый вариант языка VBScript, который используется в технологии HTML, а именно в DHTML, т.е. для динамической работы с содержимым гипертекстовых документов, наравне с JavaScript, JScript. Однако даже сейчас VBScript поддерживается далеко не всеми современными и наиболее распространёнными браузерами, в отличие от JavaScript, что сокращает область его использования.

Сердцем любой программы на Visual Basic является исполняемый файл и ряд динамических библиотек (DLL - Dynamic Link Library, библиотека динамического связывания). Кроме того, Visual Basic обладает интегрированной возможностью использования внешних компонентов, встраиваемых в программу и облегчающих работу программиста (технология ActiveX). Благодаря тому, что компоненты ActiveX являются независимыми от исходного языка, то в программах Visual Basic можно использовать сторонние компоненты, которые могут помочь в осуществлении поставленной цели.

1.3. Элементы языка

В данной курсовой работе использовались различные типы данных:

byte

integer

long

boolean

string (в формате UNICODE)

variant

пользовательские типы

массивы элементов данных типов

Объявление переменных:

(Dim | Private | Public | Static) <имя переменной> As <тип переменной>

Описание констант:

Const <идентификатор> As <тип>

Использовались записи:

Type <название>

<поля_записи>

End Type

А также использовались основные операторы:

Альтернативные операторы условия

If <условие> Then

<оператор 1>

[ElseIf <условие> Then

<оператор 2>…]

[Else <оператор 3>]

End If

Операторы выбора

Select Case <условие>

[Case <метка 1>

<оператор 1>]

………

[Case Else

<оператор 2>]

End Select

Циклы

с предусловием

Do (While | Until) <условие>

<оператор 1>

Loop

While <условие>

<оператор 1>

Wend

со счётчиком

For <счётчик>=<начальное значение> To <конечное значение> [шаг]

<оператор 1>

[Exit For <оператор 2>]

Next <счётчик>

с постусловием

Loop

<оператор 1>

Do (While | Until) <условие>

Процедуры

[Dim | Private | Public | Static] Sub <имя процедуры> ([список параметров])

<тело процедуры>

End Sub

Функции

[Dim | Private | Public | Static] Function <имя функции> ([список параметров]) [As <тип возвращаемого значения>]

<тело процедуры>

End Function

Массивы

Статический

Dim <иденитифекатор>([нижняя граница to] верхняя граница) As <тип>

Динамический

Dim <идентификатор> As <тип> - описание массива

1.4. Средства обмена данными

Внутренний обмен данными осуществляется с помощью переменных.

Переменные могут передаваться в процедуры и функции тремя способами:

По ссылке. Передаётся адрес переменной, что позволяет изменять ее значение. Используется By Ref, режим по умолчанию.

По значению. Создается локальная копия переменной равная передаваемой. Значение изменить нельзя. Используется By Val.

Переменная может быть описана как глобальная и расположена вне процедур и функций. Таким образом она будет глобально доступна.

1.5. Встроенные элементы

Check boxФлажок для выбора из двух вариантов

Combo boxПоле ввода со списком

FrameГруппирование элементов управления

ImageДобавление на форму изображений

LabelОтображение надписей

LineИзображение линий для легкого зрительного разделения частей интерфейса

List boxОтображение списка элементов

Option buttonГруппы переключателей

Text boxПоле ввода текста

TimerТаймер

Не встроенные, но используемые:

Common DialogСтандартные системные диалоги(comdlg32. ocx)

List ViewРасширенный список элементов(mscomctl. ocx)

Rich Text BoxРедактор текстовых полей (richtx32. ocx)

Status BarСтрока состояния для отображения глобальных параметров (путь к БД, необходимость сохранения и т.д.) (mscomctl. ocx)

MonthViewКалендарь (comct332. ocx)

1.6. Средства отладки программ

При написании программ возникают ситуации, когда, например, необходимо выполнить участок программы по действиям, либо найти место и причину возникающей ошибки. Для этих целей в Visual Basic реализован механизм отладки, позволяющий выполнять программу по шагам и наблюдать за значениями переменных. Используя точки останова, окно наблюдения значений переменных можно изучать выполнение программы: выполнение операций, ветвлений, вызовов процедур и функций и т.д.

Также Visual Basic предоставляет возможность встроенной в код обработки исключений (ошибок, связанных с неправомерными действиями программы, происходящими из-за ошибок в коде, либо состояния среды выполнения – операционной системы). Для этого в языке реализованы конструкции:

On Error GoTo <метка>.

Если во время выполнения программы возникнет исключение в одном из операторов, расположенных после данной конструкции, то управление передается обработчику ошибок, указанному меткой.Т. е. выполнение программы продолжится с места, следующего за меткой. Если в некоторый момент обработку ошибок следует отключить, то используется конструкция On Error GoTo 0.

В обработчик ошибок можно включить оператор Resume, который указывает на игнорирование любых ошибок. В этом случае никакая ошибка не будет обработана, что весьма чревато.

Resume имеет несколько форм:

Resume возобновляет выполнение программы с оператора, вызвавшего ошибку;

Resume Next возобновляет выполнение программы со следующего оператора;

Resume <метка> возобновляет выполнение программы с оператора, следующего за указанной меткой.

2. конструкторская часть

2.1. Общие сведения

Программа 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-компонентов

При написании программы использовались следующие программы:

Среда разработки

Microsoft Visual Basic 6.0

Borland/Inprise Delphi 6.0

Графический инструметарий

XaraX 1.0

Xara3D 5.0

Microangelo 5.57

IrfanView 3.91

ICA Converter 1.1.0.8

Написание справки, пояснительной записки и структурной схемы

Microsoft Office Word Professional 2003

Help&Manual 3.3

Microsoft Office Visio Professional 2003

Дополнительно использовалась программа UGH! 0.942

2.2. Функциональное назначение

Данная программа представляет собой удобное средство для работы с однотабличной ненормализованной базой данных. Максимально удобный и функциональный интерфейс облегчает работу с базой данных. Запросная система, позволяющая добавлять, удалять, сортировать, выводить, обменивать и преобразовывать данные, построена на основе нескольких универсальных запросов, охватывающих весь круг решаемых задач:

Добавление полей и записей

Удаление полей и записей

Сортировка записей по любому полю по и против алфавита

Вывод записей по любому полю, подходящий по параметрам:

Равенства выражению

Больше выражения

Меньше выражение

Встречается в таблице N раз

Встречается в таблице более N раз

Встречается в таблице менее N раз

Обмен полей и записей

Переименование и смена типа полей (произвольные строки и целые числа)

Запросы формируют копии базы данных, которые можно сохранять в качестве новых баз данных.

По любым числовым данным можно строить диаграммы следующих видов:

Столбчатая

Линейная

Точечная

Круговая

Столбчатые, линейные, точечные и круговые диаграммы можно строить в плоскости и в аксонометрической проекции (3D, только для столбчатой и круговой).

Результаты работы с базой данных можно сохранить в HTML.

В случае необходимости защиты данных предусмотрена возможность защиты по паролю и шифрования данных в базе данных.

В данной реализации программы база данных может содержать поля трех типов данных:

строки длиной до ~248 символов

целые числа в диапазоне - 2147483647. .2147483647

псевдоформат Дата, являющийся строковым, но редактируемый с использованием календарем

2.3. Описание логической структуры программы

2.3.1. Главная форма (MainForm. frm) (рис.1)

Запуск программы.

Запускается форма MainForm(строка 1), в процедуре Form_Load(строка 245) устанавливаются начальные значения и состояние панели инструментов.

Создание новой БД.

Вначале управление получает процедура CreateDB_Click(строка 96), в которой вызывается стандартный системный диалог выбора файла. Если файл выбран, то вызывается процедура NewDB(строка 2788), создающая новую БД, и процедурой ShowTable(строка 2378) отображается пустая таблица.

Открытие БД.

В процедуре OpenDB_Click(строка 292) вызывается диалог выбора файла. Если файл был выбран вызывается функция LoadDB(строка 2600), загружающая БД из файла. В случае отсутствия ошибок в файле и нужных прав для открытия файла кнопки на панели инструментов меняют состояние при помощи процедуры DisEnImage(строка 37) и отображается загруженная таблица процедурой ShowTable(строка 2378). Если прав недостаточно для открытия БД будет вызван мастер защиты (рис.5, Рис.6).

Сохранение БД.

В процедуре SaveDB_Click(строка 345) вызывается диалог выбора файла. Если файл был выбран, то изменяется путь к текущей БД в переменной DBPath(строка 2309) и БД сохраняется в указанный файл процедурой FlushDB(строка 2500).

Закрытие БД.

Если переменная DBChanged(строка 2311), являющаяся флагом несохраненных изменений в БД, равна истине, то предлагается отменить закрытие. Если пользователь все же закрывает БД, то процедура ClearAll(строка 2806) освобождает используемую под таблицы память, а процедура ShowTable(строка 2378) скрывает пустую таблицу.

Создание резервной копии.

В процедуре ResCopyDB_Click(строка 328) сначала вызывается диалог выбора файла. Если он удачен, то проверяется совпадение текущей БД с ее создаваемой копией. Если файлы различны API функция CopyFile(строка 2824) создает копию файла текущей БД и появляется сообщение об удачном выполнении операции.

Выход (завершение работы).

Выход из программы реализован процедурой ExitPr_Click(строка 124). В ней происходит проверка на внесенные в БД изменения, которые еще не были сохранены. Если изменений нет, или пользователь выбрал выход без сохранения, программа завершает свою работу.

Запуск Мастера запросов (QueryMasterForm. frm) (рис.2)

При выборе Запросы→Мастер запросов выполняется процедура QueryM_Click. (строка 319) В ней модально показывается форма QueryMasterForm(рис.2). Управление передается этой форме, ее процедуре Form_Load(строка 785). В ней настраивается внешний вид формы. При выборе элемента в списке QueryTypeCombo вызывается процедура QueryTypeCombo_Click(строка 801), заполняющая список QuerySubtypeCombo значениями в зависимости от поля QueryTypeCombo. ListIndex. При нажатии на изображении «+» в правой части окна вызывается процедура AddImage_Click(строка 667). В ней в зависимости от полей QueryTypeCombo. ListIndex и QuerySubtypeCombo. ListIndex вызываются вложенные процедура AddStr(строка 659) и функция Generate_XXX(строки 2982, 2996, 3031, 3043, 3068, 3089). AddStr определена в модуле формы и выполняет проверку в добавление строки в список QueryList. Generate_XXX, являющаяся серией функций, начинающихся Generate_, и определенных в модуле QueryRunner, формируют тексты запросов на основе диалогов. Нажатие изображения «-» вызывает процедуру DelImage_Click(строка 774), удаляющую выбранный в списке QueryList элемент. Если нажать на изображение «X», то будет вызвана процедура ClearImage_Click(строка 762), удаляющая все элементы в списке QueryList. При щелчке по кнопке CancelBut управление переходит к процедуре обработки этого события. Эта процедура выгружает форму QueryMasterForm из памяти. Ну и нажатие на кнопку «Выполнить» приводит к выполнению процедуры RunBut_Click(строка 832), которая вызывает процедуру RunQuery(модуль QueryRunner) для каждого элемента списка QueryList, а также показывает выбранную таблицу вызовом ShowTable(QMFDBIndex). После этого список QueryList очищается и выдается сообщение о завершении выполнения запросов.

Формирование HTML.

При выборе пункта меню Результаты→Формирование HTML вызывается процедура HTMLCreator_Click(строка 208). В ней вызывается диалог выбора файла. Если файл выбран, то процедура CreateHTML сохраняет текущую БД в файл, иначе выдается сообщение об отмене формирования HTML.

Защита (PasswordForm. frm) (рис.9).

При выборе Настройки→Защита вызывается процедура Security_Click(строка 356). В ней показывается форма PasswordForm в режиме настройки параметров безопосности. Если после завершения работы с формой значение переменной PasswordForm. res истинно, то новые параметры сохраняются и выбается соответствующее сообщение. После этого форма PasswordForm выгружается из памяти.

Также данная форма используется при открытии БД, защищенной паролем.

О программе (AboutForm. frm) (рис.10).

При выботе пункта О программе в меню? вызывается процедура AboutProg_Click(строка 11). В ней модально отображается форма AboutForm.

Помощь.

После выбора? →Помощь управление переходит к процедуре HelpProg_Click(строка 140), запускающей с помощью API функции ShellExecute(строка 2827) браузер с файлом программной справки. Форму можно перетаскивать мышью за любое место. Для этого используются процедуры MDown(строка 2874), MUp(строка 2880), MMove(строка 2862). В процедуре MMove вызываются API функции GetWindowRect(строка 2846) и MoveWindow(строка 2847). При щелчке по надписи «Xerx» вызывается API функция ShellExecute(строка 2827), вызывающая программу, зарегистрированную в системе как почтовая.

2.3.2. Мастер диаграмм (DiagMasterForm. frm) (рис.11)

При выборе Результаты→Мастер диаграмм выполняется процедура DiagDraw_Click(строка 114). В ней модально показывается форма DiagMasterForm. Управление передается этой форме, ее процедуре Form_Load(строка 1196). В ней настраивается внешний вид формы, очищаются все списки и в список TableIndexCombo добавляются названия всех открытых таблиц.

При выборе элемента в TableIndexCombo в процедуре TableIndexCombo_Click(строка 1306) список TableColList заполняется заголовками полей выбранной таблицы. При двойном щелчке в TableColList вызывается процедура TableColList_DblClick(строка 1291), в которой выбранный заголовок вместе с названием таблицы добавляется в список SelectColList с предварительной проверкой на уже добавленность. Двойной щелчок в списке SelectColList вызывает процедуру SelectColList_DblClick(строка 1301), в которой выбранная строчка удаляется.

Выбор элемента списка DiagTypeCombo приводит к вызову процедуры DiagTypeCombo_Click(строка 1184), в которой изменяется картинка типа диаграмм в компоненте DiagTypeImage, а также скрывается либо показывается фрейм Frame2.

Нажатие на кнопку Отмена закроет форму DiagMasterForm.

Нажатие на кнопку Принять приводит к вызову процедуры OkBut_Click(строка 1275), в которой вызывается функция GettingDiagData(строка 1229), формирующая данные для диаграммы. В случае успешности этой загрузки загружается в память форма DiagResForm(рис.16) и вызывается ее процедура InitDiagData(строка 1424), после чего загруженная форма модально показывается.

2.3.3. Работа с окном диаграммы (DiagResForm. frm) (рис.16)

Форма DiagResForm, вызываемая из формы DiagMasterForm(рис.11) кнопкой «Принять», предназначена непосредственно для построения диаграмм. Диаграммы строятся на канве компонента Chart типа PictureBox, используя его методы. Кнопка Image1 с изображение дискеты позволяет сохранить диаграмму в качестве BMP файла. Для этого предназначена процедура Image1_Click(строка 2046), в которой, используя компонент CD типа CommonDialog, указывается путь к создаваемому растровому файлу, после чего (если файл был указан) вызывается встроенная процедура SavePicture, сохраняющая диаграмму. Нажатие на изображение Image2 с изображением вопроса показывает модально окно настроек DiagOptForm(рис.15). Кнопка Image3 с изображение стрелки выгружает форму из памяти. Процедура DrawDiagram(строка 1975), вызываемая при изменении размеров и изменении настроек, непосредственно не строит диаграммы, она лишь заливает фон градиентной заливкой (процедура ColorFill(строка 1440)), а также в зависимости от типа строимой диаграммы вызывает процедуры DrawCircle(строка 1673) (круговая диаграмма) и DrawPoint(строка 1749) (колончатая, точечная и линейчатая диаграммы). Также DrawCircle вызывает процедуру OutOneElem(строка 1482), стоящую один элемент круговой диаграммы. Данные для построения хранятся в массиве DiagData(строка 1387), режим построения (тип диаграммы) в переменной DrawingMode(строка 1388), а флаг использования 3D в переменной Use3D(строка 1388). Значения этих переменных определяются в процедуре InitDiagData(строка 1424). При перемещении мыши над диаграммой Chart вызывается процедура Chart_MouseMove(строка 1988), выводящая в метку Label2 текст о значении функции в указанной точке. Перемещение ползунка полосы прокрутки VScroll вызывает процедуру VScroll_Change(строка 2122), изменяющую значение переменной Ellipce в зависимости от позиции ползунка и перерисовывающую диаграмму.

2.3.4. Работа с окном настроек диаграммы (DiagOpt. frm) (рис.15)

На закладке «Цвета и текст» щелчок по любому компоненту Frame2 вызывает диалог выбора цвета (используется ColorDlg). Изменение цвета фреймов с индексами 0 или 1 вызывает процедуру ColorFill(строка 1440) для компонента Picture1 типа PictureBox. В списке List1 хранятся надписи элементов диаграммы, а в массиве List1. ItemData хранятся цвета соответствующих элементов. В текстовом поле Text1 можно менять значение выбранной в List1 записи. При нажатии кнопки [Enter] вызывается процедура Text1_KeyDown(строка 2203), сохраняющая значение подписи в массив List1. Item. При нажатии кнопки Принять переменной res присваивается значение 1, что сигнализирует об необходимости применить внесенные изменения. После этого форма скрывается. При нажатии на кнопку Отмена форма делается невидимой без изменения переменной res.

2.3.5. Работа с редактором записей (EditRecordForm. frm) (рис.3)

Двойной щелчок по строке в списке ListView вызывает процедуру ListView_DblClick(строка 220), в которой настраивается внешний вид формы EditRecordForm, вызывается процедура LoadData(строка 855), определенная в модуле формы, и форма модально отображается. При загрузке формы вызываются процедура Form_Load(строка 891), настраивающая внешний вид формы. В списке CellList_Click выводятся поля выбранной в списке ListView записи. Выбор элемента в списке сопровождается вызовом процедуры CellList_Click(строка 866), в которой в зависимости от типа выбранного поля в метку Label6 выводится соответствующий текст, а также процедурой ButEnabled(строка 2934), определенной в модуле DBConst, меняется состояние кнопки «Редактор». После этого в текстовое поле Text1 загружается значение выбранного поля и полностью выделяется. Нажатие кнопки «Редактор» вызывает процедуру EditorBut_Click(строка 917), в которой сначала проверяется тип редактируемого поля, затем, если оно числовое, выдается сообщение об ошибке, иначе поле сравнивается с форматом даты. Если формат совпадает и флажок MonthForm. Check1(рис. 19) (установлен – календарь не показывается) не установлен, то загружается форма TextEditForm(рис.8) (в ином случае загружается форма MonthForm), в текстовый редактор TextEdit типа RichTextBox загружается значение из текстового поля Text1. Если окно TextEditForm было закрыто с сохранением текста, то переменная TextEditForm. res истинна и измененный текст загружается в текстовое поле Text1. После этого форма TextEditForm выгружается из памяти. Нажатие на кнопку «Применить» вызывает процедуру FlipBut_Click(строка 1010), проверяющую введенное значение на корректность (соответствие типу и разрядной сетке) и, в случае отсутствия ошибок, присваивает выбранному в списке CellList элементу введенное значение. В случае какой-либо ошибки выдается соответствующее сообщение. Нажатие на кнопку «Вернуть» восстанавливает все поля записи из БД в процедуре ReturnBut_Click(строка 908), вызывающей последовательно LoadData(строка 855) и OverloadList(строка 883), получающие и копирующие запись во временный буфер Arr(строка 853). Нажатие на кнопку «Отмена» вызывает процедуру CancelBut_Click(строка 982), выгружающая форму EditRecordForm из памяти. Кнопка «Принять» вызывает процедуру SelectBut_Click(строка 954), работа которой заключается в сохранении полей записи из локального массива Arr в глобальную таблицу.

2.3.6. Работа с окном выбора (SelectForm. frm) (Рис.6)

Выбор записей и полей БД производится при помощи формы SelectForm, предоставляющей удобный выбор среды указанных списков. В модуле формы глобально объявлены функции SelectDlg(строка 556) и MultiSelectDlg(строка 598), предназначенные для организации диалога по выбору одного (SD) или нескольких (MSD) записей (SD) либо полей (SD, MSD) из указанной при вызове таблицы. Функция SelectDlg возвращает число равное номеру выбранного элемента, либо «-1», если выбор был отменен. Функция MultiSelectDlg возвращает строку, в которой через запятую перечислены индексы всех выбранных элементов. Если строка пуста, то это однозначно указывает, что ничего не было выбрано.

2.3.7. Работа с редактором текста (TextEditForm. frm) (рис.8)

Нажатие кнопки «Редактор» вызывает форму «Редактор текстовых полей» (TextEditForm), главной частью которой является компонент TextEdit типа RichTextBox. На панель Toolbar1, расположен ряд кнопок, обработка нажатий которых расположена в процедуре Toolbar1_ButtonClick(строка 522). Кнопка «ClearText» очищает весь текст в TextEdit, а кнопка «SaveText» указывает вызывающей форме о необходимости внести изменения в данные. Кнопки «CopyText», «PasteText», «CutText» и «DeleteText» работают с системным буфером обмена. Кнопка «Properties» позволяет, используя компонент FontDlg, настраивать шрифт в редакторе.

2.3.8. Работа с календарем (MonthForm. frm) (рис. 19)

При загрузке формы в процедуре Form_Load настраивается внешний вид окна а также переменной res(строка 2231), хранящей результат работы с окном, присваивается значение 0. При нажатии кнопки Принять вызывается процедура YesBut_Click(строка 2249), устанавливающая значение res в 1 (дата выбрана) и скрывает форму. При нажатии кнопки Текст вызывается процедура EditBut_Click(строка 2237), устанавливающая значение res в - 1 (редактирование как текст) и также скрывает форму. Нажатие кнопки Отмена просто скрывает форму в процедуре CancelBut_Click(строка 2233).

2.3.9. Работа DBConst (DBConst. bas)

В модуле описаны глобальные константы, процедуры:

SoundClick(строка 2914), для проигрывания звука нажатия на кнопку

IsInteger(строка 2918), для проверки возможности преобразования строки в целое число

ButEnabled(строка 2934), для анимации кнопок

2.3.10. Работа DBTypes (DBTypes. bas)

Модуль предназначен для обеспечения всей работы с БД как с физическим файлом. Для этого в модуле объявлены необходимые типы, переменные и константы. Также модуль содержит следующие процедуры и функции:

DelCol_(строка 2318), процедура для удаления поля из указанной таблицы

DelRow_(строка 2348), процедура для удаления записи из указанной таблицы

TestDBChanged(строка 2369), процедура проверки изменения БД и отображения дискеты в первом секторе строки состояния главной формы

ShowTable(строка 2378), процедура вывода указанной БД на экран

ItColAlreadyCreate(строка 2419), функция проверки уникальности поля

AddCol(строка 2432), процедура добавление поля

AddField(строка 2465), процедура добавления записи

DelTable(строка 2475), процедура удаления указанной таблицы из массива таблиц DB

CodeDecode(строка 2483), функция шифрует строки

FlushDB(строка 2500), процедура сохранения БД

LoadDB(строка 2600), функция загрузки БД

NewDB(строка 2788), процедура создания новой БД и инициализации настроек

ClearAll(строка 2806), процедура освобождения занимаемой памяти и сброса настроек

ClearHeader(строка 2814), процедура установки полей заголовка БД в стандартное (начальное) состояние

2.3.11. Работа QueryRunner (QueryRunner. bas)

Модуль предназначен для работы с запросами. Для формирования и выполнения запросов в модуле описаны необходимые константы и процедуры с функциями:

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

Generate_Add(строка 2982) – добавление полей и записей

Generate_Del(строка 2996) – удаление полей и записей

Generate_Sort(строка 3031) – сортировка записей

Generate_Out(строка 3043) – вывод записей

Generate_Swap(строка 3068) – перестановка полей и записей

Generate_Change(строка 3089) – изменение типа и заголовка поля

ErrorInQuery(строка 3105) – сообщение об ошибке в запросе, связано с ручной правкой запросов и/или некорректными параметрами

TestZero(строка 3109) – проверка параметра на равенство нулю. В случае равенства вызывается ErrorInQuery

Выполнение запросов:

AddRun(строка 3118) – добавление полей и записей

DelRun(строка 3187) – удаление полей и записей

SortRun(строка 3227) – сортировка записей

OutRun(строка 3340) – вывод записей. Используются дополнительные функции:

Equal(строка 3290) – сравнение передаваемых значений в соответствии с типами

CalcCount(строка 3308) – подсчет количества записей с полем равным заданному

EarlierDontFind(строка 3316) – проверка на существование ранее идентичного поля по записям

FindRow(строка 3326) – поиск записи

SwapRun(строка 3464) – перестановка полей и записей

ChangeRun(строка 3518) – изменение типа и заголовка поля

RunQuery(строка 3583) – выполнение произвольного запроса. Выполняет ветвление и передачу процедурам указанных в запросе данных

2.4. Запуск и выполнение

Для запуска программы необходимо запустить DBX. exe. Сразу после запуска (при условии наличия в системе всех необходимых файлов, перечисленных в общих сведениях) будет открыто окно заставки(рис.17). После нажатия клавишь Enter или Esc будет загружено главное окно программы.

Программа может быть запущена с любого носителя данных, будь то: жесткий диск (HDD), дискета (FDD), CD-диск (CD - и DVD - ROM), различных внешних устройств (Flash и ZIP) и т.д., а также по локальной сети.

3. технологическая часть

3.1. Руководство системного программиста

3.1.1. Общие сведения о программе

Данная программа представляет собой удобное средство для работы с однотабличной ненормализованной базой данных. В программу встроена запросная система, позволяющая добавлять, удалять, сортировать, выводить, обменивать и преобразовывать данные, построенная на основе нескольких универсальных запросов, охватывающих весь круг конкретных решаемых задач.

Системные требования

Процессор не ниже Intel Pentium 133,

Операционная система семейства Windows не ниже 9x, желательно XP,

Оперативная память не менее 32MB,

Мышь (не менее 1 кнопки),

Клавиатура,

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'.

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

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

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

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

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

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

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

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

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

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

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

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

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

литература

Microsoft Corporation Microsoft Visual Basic 6.0 Programmer’s Guide, Microsoft Press, 2003 г.

Microsoft® Win32® Programmer's Reference, 1996 г.

Приложение 1

Исходный код программы

Форма: MainForm. frm

0' разница ширины и высоты формы и TabStrip'а

1Dim dW1%, dH1%

2' разница ширины и высоты TabStrip'а и ListView'а

3Dim dW2%, dH2%

4' последний выбранный элемент

5Dim saveItemIndex%

6' текущая таблица

7Public DBCurIndex%

8' последний Image, над которым был курсор

9Dim OldImageIndex%

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

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

Курсовая работа: Создание базы данных

Похожие работы: