unit Main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Buttons,
Data.DB, Data.Win.ADODB, Vcl.ComCtrls, Vcl.Grids, Vcl.DBGrids, Vcl.DBCtrls, HTMLHelpViewer;
type
TFmain = class(TForm)
PTop: TPanel; // вехняя панель скнопками (alTop)
PBottom: TPanel; // нижняя панель с кнопками (alBottom)
PMainTest: TPanel; // панель тестирования (alNone):
PResp: TPanel; // панель со списком респондентов (alLeft)
PTest: TPanel; // панель со списком тестов (alClient)
PFioResp: TPanel; // панель в панеле респондетов вверх
PNameTest: TPanel; // панель в панеле тестов верх
LBRespondent: TListBox; // список респонддентов для тестирования
LBTest: TListBox; // смена статуса
BBQuitT: TBitBtn; // верхняя кнопка выход
BBTest: TBitBtn; // кнопка тестирования
PMainPsy: TPanel; // главная панель психолога (alNone):
PAddResp: TPanel; // панель редактирования списка респондентов
LFamilyResp: TLabel; // метка фамилия респондента
LNameResp: TLabel; // метка имя респондента
LSurNameResp: TLabel; // метка отчество респондента
LSexResp: TLabel; // метка пол респондента
LBornResp: TLabel; // метка дата рождения респондента
BBAdd: TBitBtn; // кнопка добавить нового респондента
BBEdit: TBitBtn; // кнопка редактировать данные респондента
BBDelete: TBitBtn; // кнопка удалить респондента
EFamily: TEdit; // поле ввода фамилии респондента
EName: TEdit; // поле ввода имени респондента
ESurname: TEdit; // поле ввода отчества респондента
CBSex: TComboBox; // поле выбора пола респондента
DTPBorn: TDateTimePicker; // поле выбора даты рождения респондента
DBGRespondent: TDBGrid; // список респондентов
PExperiment: TPanel; // панель с данными эксперимента (alBottom):
PTopExp: TPanel; // разделительная панель (alTop)
DBGTesting: TDBGrid; // список пройденных экспериментов (alLeft)
PButExp: TPanel; // панель кнопок эксперимента (alRight):
BBResult: TBitBtn; // кнопка просмотр результатов тестирования
BBProtocol: TBitBtn; // кнопка просмотра протокола тестирования
PResultProtocol: TPanel; // панель результатов или протокола (alClient):
DBGResult: TDBGrid; // список результатов тестирования (alNone)
DBGProtocol: TDBGrid;
RGStatus: TRadioGroup;
PFind: TPanel;
LFind: TLabel;
EFind: TEdit;
BBFind: TBitBtn;
PFindResp: TPanel;
EFindResp: TEdit;
LFindResp: TLabel;
BBProtocolOtchet: TBitBtn;
BBResultOtchet: TBitBtn;
procedure FormActivate(Sender: TObject);
procedure BBTestClick(Sender: TObject); // кнопка запуск тестирования
procedure BBAddClick(Sender: TObject);
procedure RGStatusClick(Sender: TObject);
procedure BBResultClick(Sender: TObject);
procedure BBProtocolClick(Sender: TObject);
procedure LBRespondentClick(Sender: TObject);
procedure LBTestClick(Sender: TObject);
procedure BBFindClick(Sender: TObject);
procedure EFindRespChange(Sender: TObject);
procedure BBEditClick(Sender: TObject);
procedure DBGRespondentCellClick(Column: TColumn);
procedure DBGRespondentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure BBDeleteClick(Sender: TObject);
procedure Otchet(Dannye: Boolean);
procedure BBResultOtchetClick(Sender: TObject);
procedure BBProtocolOtchetClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Fmain: TFmain;
implementation
{$R *.dfm}
Uses
Variable, // модуль с глобальными переменными
ShellApi, Password, Data, // модуль для обеспечения запуска программ
frxClass; // модуль для подключения отчёта
function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): THandle;
// функция запуска файла программы
begin
Result := ShellExecute(Application.MainForm.Handle, nil, PChar(FileName), PChar(Params),
PChar(DefaultDir), ShowCmd);
end;
function ExtractFileNameEx(FileName: string; var Path: string; ShowExtension: Boolean): string;
//Функция возвращает имя файла, без или с его расширением, а также путь к программе без имени файла (Path).
//ВХОДНЫЕ ПАРАМЕТРЫ
//FileName - имя файла, которое надо обработать
//ShowExtension - если TRUE, то функция возвратит короткое имя файла
// (без полного пути доступа к нему), с расширением этого файла, иначе, возвратит
// короткое имя файла, без расширения этого файла.
var
I: Integer;
S, S1 : string;
begin
//Определяем длину полного имени файла
I := Length(FileName);
//Если длина FileName <> 0, то
if I <> 0 then
begin
//С конца имени параметра FileName ищем символ "\"
while (FileName[i] <> '\') and (i > 0) do
i := i - 1;
// Копируем в переменную S параметр FileName начиная после последнего
// "\", таким образом переменная S содержит имя файла с расширением, но без
// полного пути доступа к нему
S := Copy(FileName, i + 1, Length(FileName) - i);
i := Length(S);
//Если полученная S = '' то фукция возвращает ''
if i = 0 then
begin
Result := '';
Exit;
end;
//Иначе, получаем имя файла без расширения
while (S[i] <> '.') and (i > 0) do
i := i - 1;
//... и сохраням это имя файла в переменную s1
S1 := Copy(S, 1, i - 1);
//если s1='' то , возвращаем s1=s
if s1 = '' then
s1 := s;
//Если было передано указание функции возвращать имя файла с его
// расширением, то Result = s,
//если без расширения, то Result = s1
if ShowExtension = TRUE then
Result := s
else
Result := s1;
Path := FileName;
i := Pos(S,Path);
Delete(Path, i, Length(S));
end
//Иначе функция возвращает ''
else
Result := '';
end;
procedure TFmain.BBTestClick(Sender: TObject);
var
ST, SR : String; // хранение названия теста и имени респондента
FT : String; // имя запускаемого файла
S2 : String; // путь к запускаемой программе
ID : String; // идентификационный номер респондента
i : Integer; // счётчик
begin
// по умолчанию открыто окно для проведения тестирования
if not PMainTest.Visible then
begin
// сделать панель управления данными психологом (ввод данных, просмотр результатов) видимой
PMainPsy.Visible := False;
// сделать панель тестирования видимой
PMainTest.Visible := True;
end;
// сменить курсор на курсор ожидания
Screen.Cursor := crHourGlass;
// запомнить имя выбранного теста
ST := LBTest.Items[LBTest.ItemIndex];
// запомнить имя выбранного респондента
SR := LBRespondent.Items[LBRespondent.ItemIndex];
// подготовить тест к запуску
with DM do
begin
with ADOQTest do
begin
// очистить поле запроса
SQL.Clear;
// сформировать запрос для выбора всех данных
SQL.Add('SELECT * FROM Test WHERE NameTest='''+ST+'''');
// активировать запрос
Active := TRUE;
// считать имя запукаемого файла
FT := FieldByName('RunFile').AsString;
end;
// выбрать респондента для тестирования
with ADOQRespondent do
begin
// очистить поле запроса
SQL.Clear;
// сформировать запрос для выбора всех данных
SQL.Add('SELECT * FROM Respondent');
// активировать запрос
Active := TRUE;
for i := 0 to RecordCount-1 do
begin
// найти запись респондента в базе данных
If (FieldByName('Family').AsString+' '+FieldByName('Name').AsString+' '+
FieldByName('SurName').AsString) = SR then
begin
// счиать его идентификатор из базы данных и сохранить его в
ID := FieldByName('ID_Respondent').AsString;
// если запись найдена, закончить перебор и выйти из цикла
Break;
end;
// перейти к следующей записи
Next;
end;
end;
end;
// считать путь к запускаемому файлу
FT := S + FT;
// скорректировать имя для выбора папки запуска
FT := ExtractFileNameEx(FT,S2,True);
// сменить текущюю папку на папку запуска теста
ChDir(S2);
// восстановить курсор на стандартный
Screen.Cursor := crDefault;
// запустить файл теста
ExecuteFile(FT,ID,'',SW_SHOW);
end;
procedure TFmain.Otchet(Dannye: Boolean);
var
t : TfrxMemoView; // поле вывода текста отчёта
ID_Respondent, // номер респондента
ID_Test : Integer; // номер теста
Respondent, // ФИО респондента
APDM : String; // название АПДМ
TestDate, // дата тестирования
TestTime : TDateTime; // время тестирования
begin
with DM do
begin
// считать номер выбранного эксперимента
with ADOQTesting do
begin
ID_Testing := FieldByName('ID_Testing').AsInteger;
// считать номер респондента
ID_Respondent := FieldByName('ID_Respondent').AsInteger;
// считать номер АПДМ
ID_Test := FieldByName('ID_Test').AsInteger;
// считать дату тестирования
TestDate := FieldByName('Testing_Date').AsDateTime;
// считать время тестирования
TestTime := FieldByName('Testing_Time').AsDateTime;
end;
// работать с БД респондент
with ADOQTemp do
begin
// скорректировать запрос
with SQL do
begin
// очистить старый запрос
Clear;
// считать данные респондента по номеру ПЭ
Add('SELECT * FROM Respondent WHERE ID_Respondent = '+IntToStr(ID_Respondent));
end;
// активировать запрос
Active := true;
// считать данные респондента
Respondent := FieldByName('Family').AsString;
Respondent := Respondent + ' ' + FieldByName('Name').AsString;
Respondent := Respondent + ' ' + FieldByName('Surname').AsString;
end;
// работать с БД тест
with ADOQTemp do
begin
// скорректировать запрос
with SQL do
begin
// очистить старый запрос
Clear;
// считать данные респондента по номеру ПЭ
Add('SELECT * FROM Test WHERE ID_Test = '+IntToStr(ID_Test));
end;
// активировать запрос
Active := true;
// считать данные респондента
APDM := FieldByName('NameTest').AsString;
end;
if Dannye then
begin
// отобразить результаты выбранного эксперимента
with ADOQResult do
begin
// сменить запрос результата выбранного эксперимента
with SQL do
begin
// очистить "старый" запрос
Clear;
// выбрать результаты в соответствии с выбранным экспериментом
Add('SELECT * FROM Result WHERE ID_Testing = '+IntToStr(ID_Testing));
end;
// активировать запрос
Active := True;
end;
end
else
begin
// отобразить результаты выбранного эксперимента
with ADOQProtocol do
begin
// сменить запрос результата выбранного эксперимента
with SQL do
begin
// очистить "старый" запрос
Clear;
// выбрать результаты в соответствии с выбранным экспериментом
Add('SELECT * FROM Protocol WHERE ID_Testing = '+IntToStr(ID_Testing));
end;
// активировать запрос
Active := True;
end;
end;
// прочитать путь к программе
S := ExtractFilePath(Application.ExeName);
// загрузить отчёт
if Dannye then
FrxReport.LoadFromFile(S+'base\Result.fr3')
else
FrxReport.LoadFromFile(S+'base\Protocol.fr3');
// связать переменную с нужным полем по имени (поле именовано MemoResp)
t := TfrxMemoView(frxReport.FindObject('MemoResp'));
// если переменная Respondent не пустая
if Respondent <> '' then
// если поле MemoResp в отчёте существует
if t <> nil then
// поместить в это поле значение переменной Respondent
t.Memo.Text := Respondent;
// аналогично
// программно поместить в отчёт название АПДМ
t := TfrxMemoView(frxReport.FindObject('MemoAPDM'));
if APDM <> '' then
if t <> nil then
t.Memo.Text := APDM;
// программно поместить в отчёт дату тестирования
t := TfrxMemoView(frxReport.FindObject('MemoDate'));
if DateToStr(TestDate) <> '' then
if t <> nil then
t.Memo.Text := DateToStr(TestDate);
// программно поместить в отчёт время тестирования
t := TfrxMemoView(frxReport.FindObject('MemoTime'));
if TimeToStr(TestTime) <> '' then
if t <> nil then
t.Memo.Text := TimeToStr(TestTime);
// отобразить отчёт
if FrxReport.PrepareReport then
FrxReport.ShowPreparedReport;
end;
end;
procedure TFmain.DBGRespondentCellClick(Column: TColumn);
begin
with DM do
begin
with ADOQRespondent do
begin
EFamily.Text := FieldByName('Family').AsString;
EName.Text := FieldByName('Name').AsString;
ESurName.Text := FieldByName('SurName').AsString;
CBSex.Text := FieldByName('Sex').AsString;
DTPBorn.Date := FieldByName('Born').AsDateTime;
end;
end;
end;
procedure TFmain.DBGRespondentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
with DM do
begin
with ADOQRespondent do
begin
EFamily.Text := FieldByName('Family').AsString;
EName.Text := FieldByName('Name').AsString;
ESurName.Text := FieldByName('SurName').AsString;
CBSex.Text := FieldByName('Sex').AsString;
DTPBorn.Date := FieldByName('Born').AsDateTime;
end;
end;
end;
procedure TFmain.EFindRespChange(Sender: TObject);
begin
// изменить запрос
with DM do
begin
with ADOQRespondent do
begin
with SQL do
begin
// очистить старый запрос
Clear;
// вывести записи где фамилия "похожа" на введёный текст
Add('SELECT * FROM Respondent WHERE Family LIKE ''%'+EFindResp.Text+'%''');
end;
// активировать запрос
Active := True;
end;
end;
end;
procedure TFmain.BBDeleteClick(Sender: TObject);
var
No : Integer; // номер записи
S : String; // строка запроса
begin
// считать фамилию, имя, отчество в текущей записи
with DM.ADOQRespondent do
S := '('+FieldByName('Family').AsString+' '+
FieldByName('Name').AsString+' '+
FieldByName('Surname').AsString + ')';
// выдать запрос на удаление
If MessageDlg('Удалить текущую запись '+S+'?',mtConfirmation, [mbYes, mbNo], 0, mbNo) = mrYes then
// изменить запрос
with DM do
begin
// узнать номер редактируемой записи
with ADOQRespondent do
begin
No := FieldByName('ID_Respondent').AsInteger;
with SQL do
begin
// очистить старый запрос
Clear;
// отредактировать текущую запись
S := 'DELETE FROM Respondent WHERE ID_Respondent = '+IntToStr(No);
Add(S);
// выполнить запрос
ExecSQL;
end;
// перечитать данные для отображения на экране
with SQL do
begin
// очистить старый запрос
Clear;
// отредактировать текущую запись
S := 'SELECT * FROM Respondent';
Add(S);
// выполнить запрос
Active := True;
end;
end;
end;
end;
procedure TFmain.BBEditClick(Sender: TObject);
var
No : Integer; // номер записи
S : String; // строка запроса
begin
// выдать запрос на запись отредактированных данных в базу данных
If MessageDlg('Отредактировать текущую запись введёнными данными?',mtConfirmation, [mbYes, mbNo], 0, mbNo) = mrYes then
// изменить запрос
with DM do
begin
with ADOQRespondent do
begin
// узнать номер редактируемой записи
No := FieldByName('ID_Respondent').AsInteger;
with SQL do
begin
// очистить старый запрос
Clear;
// отредактировать текущую запись
S := 'UPDATE Respondent SET Family ='+QuotedStr(EFamily.Text)+
', Name ='+QuotedStr(EName.Text)+
', Surname ='+QuotedStr(ESurName.Text)+
', Sex ='+QuotedStr(CBSex.Text)+
', Born ='+QuotedStr(DateToStr(DTPBorn.Date))+
' WHERE ID_Respondent = '+IntToStr(No);
Add(S);
// выполнить запрос
ExecSQL;
// активировать базу данных для отображения в таблице
// очистить "старый" запрос
Clear;
// вывести список респондентов
Add('SELECT * FROM Respondent');
// активировать запрос
Active := True;
end;
end;
end;
end;
procedure TFmain.BBFindClick(Sender: TObject);
var
i: integer; // индекс выбранного элемента
begin
// если текст не введён выйти
if EFind.Text='' then exit;
// просмотреть весь список
for i:=0 To LBRespondent.Items.Count-1 Do
// если вхождение искомой подстроки в строку элемента списка есть
if pos(EFind.Text,LBRespondent.Items.Strings[i])>0 then
// присвоить списку индекс найденного элемента
LBRespondent.ItemIndex := i;
// установить фокус на элемент списка
LBRespondent.SetFocus;
end;
procedure TFmain.BBResultClick(Sender: TObject);
var
ID_Testing : String; // строка результатов тестирования
begin
// скрыть окно протокола
with DBGProtocol do
begin
Align := alNone;
Visible := False;
end;
// отобразить окно результатов
with DBGResult do
begin
Align := alClient;
Visible := True;
end;
with DM do
begin
// считать номер выбранного эксперимента
ID_Testing := ADOQTesting.FieldByName('ID_Testing').AsString;
// респондент прошёл хотя бы 1 эксперимент
if ID_Testing <> '' then
begin
// отобразить результаты выбранного эксперимента
with ADOQResult do
begin
// сменить запрос результата выбранного эксперимента
with SQL do
begin
// очистить "старый" запрос
Clear;
// выбрать результаты в соответствии с выбранным экспериментом
Add('SELECT * FROM Result WHERE ID_Testing = '+ID_Testing);
end;
// активировать запрос
Active := True;
end;
end;
end;
end;
procedure TFmain.BBResultOtchetClick(Sender: TObject);
begin
// выполнить и запустить отчёт результатов тестирования
Otchet(True);
end;
procedure TFmain.BBProtocolClick(Sender: TObject);
var
ID_Testing : String; // строка протокола тестирования
begin
with DM do
begin
// скрыть окно результатов
with DBGResult do
begin
Align := alNone;
Visible := False;
end;
// отобразить окно протокола
with DBGProtocol do
begin
Align := alClient;
Visible := True;
end;
// считать номер выбранного эксперимента
ID_Testing := ADOQTesting.FieldByName('ID_Testing').AsString;
// респондент прошёл хотя бы 1 эксперимент
if ID_Testing <> '' then
begin
// отобразить протокол выбранного эксперимента
with ADOQProtocol do
begin
// сменить запрос протокола выбрав только записи выбранного эксперимента
with SQL do
begin
// очистить "старый" запрос
Clear;
// вывести протокол тестирования в соответсвии с выбранным экспериментом
Add('SELECT * FROM Protocol WHERE ID_Testing = '+ID_Testing);
end;
// активировать запрос
Active := True;
end;
end;
end;
end;
procedure TFmain.BBProtocolOtchetClick(Sender: TObject);
begin
// выполнить и запустить отчёт результатов тестирования
Otchet(False);
end;
procedure TFmain.BBAddClick(Sender: TObject);
// ввод данных респондента
var
B : Boolean; // проверка записи
i : integer; // счётчик цикла
begin
If MessageDlg('Ввести новую запись с введёнными данными?',mtConfirmation, [mbYes, mbNo], 0, mbNo) = mrYes then
begin
// запись разрешена
B := TRUE;
with DM do
begin
// записать все данные из полей ввода в базу данных
with ADOQRespondent do
begin
// если одно из полей не введено, то не записывать данные в БД
if EFamily.Text = '' then
B := FALSE;
if EName.Text = '' then
B := FALSE;
if ESurName.Text = '' then
B := FALSE;
if CBSex.Text = '' then
B := FALSE;
if DateToStr(DTPBorn.Date) = '' then
B := FALSE;
// запись разрешена (введены все поля)
if B then
with SQL do
begin
// вводим данные в базу данных
// очистить "старый" запрос
Clear;
// добавляем новую запись с данными респондента: фамилия, имя, пол, день рождения
Add('INSERT INTO Respondent(Family, Name, SurName, Sex, Born)'+
'VALUES('+QuotedStr(EFamily.Text)+', '+QuotedStr(EName.Text)+', '+
QuotedStr(ESurName.Text)+', '+QuotedStr(CBSex.Text)+', '+
QuotedStr(DateToStr(DTPBorn.Date))+')');
// выполнить запрос
ExecSQL;
// активировать базу данных для отображения в таблице
// очистить "старый" запрос
Clear;
// вывести список респондентов
Add('SELECT * FROM Respondent');
// активировать запрос
Active := True;
end;
end;
// перечитать информацию респондентов из базы данных
with ADOQRespondent do
begin
// очистить поле запроса
SQL.Clear;
// сформировать запрос для выбора всех данных
SQL.Add('SELECT * FROM Respondent');
// активировать запрос
Active := TRUE;
// очистить список респондентов
LBRespondent.Items.Clear;
for i := 0 to RecordCount-1 do
begin
// считать название теста и присвоить его метке на форме
LBRespondent.Items.Add(FieldByName('Family').AsString+' '+
FieldByName('Name').AsString+' '+
FieldByName('SurName').AsString);
// перейти к следующей записи
Next;
end;
end;
end;
end;
end;
procedure TFmain.FormActivate(Sender: TObject);
var
i : Integer; // счётчик цикла
SH : String; // путь к файлу справки
begin
// подключение базы данных для отображения списка респондентов и тестов
S := ExtractFilePath(Application.ExeName);
// установить путь к файлу справки
SH := 'Система АПДМ.chm';
SH := S + 'Help\'+SH;
// подключить файл помощи
FMain.HelpFile := SH;
// сформировать строку подключения базы данных
SDB := 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=' + S +'\Base\PDT.mdb;Persist Security Info=True;Jet OLEDB:Database Password=12345';
with DM do
begin
// если активация включена, то выключить её
ADOConnection.Connected := False;
// присвоить сформированную строку подключения
ADOConnection.ConnectionString := SDB;
// сделать активацию активной
ADOConnection.Connected := True;
// считать информацию тестов из базы данных
with ADOQTest do
begin
// очистить поле запроса
SQL.Clear;
// сформировать запрос для выбора всех данных
SQL.Add('SELECT * FROM Test');
// активировать запрос
Active := TRUE;
for i := 0 to RecordCount-1 do
begin
// считать название теста и занести его в список
LBTest.Items.Add(FieldByName('NameTest').AsString);
Next;
end;
end;
// считать информацию респондентов из базы данных
with ADOQRespondent do
begin
// очистить поле запроса
SQL.Clear;
// сформировать запрос для выбора всех данных
SQL.Add('SELECT * FROM Respondent');
// активировать запрос
Active := TRUE;
for i := 0 to RecordCount-1 do
begin
// считать название теста и присвоить его метке на форме
LBRespondent.Items.Add(FieldByName('Family').AsString+' '+
FieldByName('Name').AsString+' '+
FieldByName('SurName').AsString);
Next;
end;
end;
// настройка элементов окна для масштабирования
SetBounds( Left - ClientOrigin.X, Top - ClientOrigin.Y,
GetDeviceCaps(Canvas.handle, HORZRES ) +
(Width - ClientWidth),
GetDeviceCaps( Canvas.handle,VERTRES )
+ (Height - ClientHeight ));
// панель тестирования скрыть
PMainTest.Visible := False;
// ширина панели тестирования весь экран
PMainTest.Width := ClientWidth;
// высота панели тестирования весь экран
PMainTest.Height := ClientHeight;
// ширина панели респондентов половина панели тестирования
PResp.Width := ClientWidth div 2;
// высота панели списка респондентов весь экран
PResp.Height := ClientHeight;
// высота панели списка тестов весь экран
PTest.Height := ClientHeight;
// панель тестирования отобразить
PMainTest.Visible := True;
// ширина панели психолога весь экран
PMainPsy.Width := ClientWidth;
// ширина панели эксперимента весь экран
PExperiment.Width := ClientWidth;
// ширина списка экспериментов респондента треть экрана
DBGTesting.Width := PExperiment.Width div 3;
// ширина кнопок эксперимента треть экрана
PButExp.Width := PExperiment.Width div 3;
// ширина панели для вывода результатов/протокола треть экрана
PResultProtocol.Width := PExperiment.Width div 3;
// выравнять кнопку "результаты"
BBResult.Left := (PButExp.Width div 2) - (BBResult.Width div 2);
BBResult.Top := (PButExp.Height div 5) - (BBResult.Height div 2);
// выравнять кнопку "протокол"
BBProtocol.Left := (PButExp.Width div 2) - (BBProtocol.Width div 2);
BBProtocol.Top := (PButExp.Height div 5)*3 - (BBProtocol.Height div 2);
// выравнять кнопку "результаты - отчёт"
BBResultOtchet.Left := (PButExp.Width div 2) - (BBResult.Width div 2);
BBResultOtchet.Top := (PButExp.Height div 5)*2 - (BBResult.Height div 2);
// выравнять кнопку "протокол - отчёт"
BBProtocolOtchet.Left := (PButExp.Width div 2) - (BBProtocol.Width div 2);
BBProtocolOtchet.Top := (PButExp.Height div 5)*4 - (BBProtocol.Height div 2);
// настроить панель добавления
PAddResp.Width := ClientWidth;
EFamily.Left := (PAddResp.Width div 5) - (EFamily.Width div 2);
EName.Left := (PAddResp.Width div 5) - (EName.Width div 2);
ESurName.Left := (PAddResp.Width div 5) - (ESurName.Width div 2);
LFamilyResp.Left := EFamily.Left;
LNameResp.Left := EName.Left;
LSurNameResp.Left := ESurName.Left;
CBSex.Left := (PAddResp.Width div 5) * 2 - (CBSex.Width div 2);
LSexResp.Left := CBSex.Left;
DTPBorn.Left := (PAddResp.Width div 5) * 3 - (CBSex.Width div 2);
LBornResp.Left := DTPBorn.Left;
BBAdd.Left := (PAddResp.Width div 5) * 4 - (BBAdd.Width div 2);
BBEdit.Left := (PAddResp.Width div 5) * 4 - (BBEdit.Width div 2);
BBDelete.Left := (PAddResp.Width div 5) * 4 - (BBDelete.Width div 2);
end;
// по "умолчанию" активно окно тестирования
PMainPsy.Visible := False;
PMainPsy.Align := alNone;
PMainTest.Visible := True;
PMainTest.Align := alClient;
// заполнить поля редактирования данными текущей записи
with DM do
begin
with ADOQRespondent do
begin
// поле ввода фамилии заполнить данными фамилии из текущей записи
EFamily.Text := FieldByName('Family').AsString;
EName.Text := FieldByName('Name').AsString;
ESurName.Text := FieldByName('SurName').AsString;
CBSex.Text := FieldByName('Sex').AsString;
DTPBorn.Date := FieldByName('Born').AsDateTime;
end;
end;
end;
procedure TFmain.LBRespondentClick(Sender: TObject);
begin
// если выбран респондент и тест кнопка "Тестирование" активна
if (LBRespondent.ItemIndex <> - 1)and(LBTest.ItemIndex <> - 1) then
BBTest.Enabled := true
else
// кнопка "Тестирование" не активна
BBTest.Enabled := false;
end;
procedure TFmain.LBTestClick(Sender: TObject);
begin
// если выбран респондент и тест кнопка "Тестирование" активна
if (LBRespondent.ItemIndex <> - 1)and(LBTest.ItemIndex <> - 1) then
BBTest.Enabled := true
else
// кнопка "Тестирование" не активна
BBTest.Enabled := false;
end;
procedure TFmain.RGStatusClick(Sender: TObject);
begin
// сменить окна программы в соответствии с выбранным статусом
case RGStatus.ItemIndex of
// подготовить режим респондент
0 : begin
// запретить кнопку тестирования (сброс "активного" состояния)
BBTest.Enabled := False;
// панель психолога скрыть
PMainPsy.Visible := False;
// панель психолога "не распахивается"
PMainPsy.Align := alNone;
// панель тестирования показать
PMainTest.Visible := True;
// панель тестирования "распахнуть" на всё доступное пространство
PMainTest.Align := alClient;
// ресондент в списоке респонденов не выбран
LBRespondent.ItemIndex := -1;
// тест в списке тестов не выбран
LBTest.ItemIndex := -1;
end;
// подготовить режим психолог
1 : begin
with FPassword do
begin
// пароль не активен
Pass := False;
// отобразить окно запроса пароля
ShowModal;
// если пароль задан правильно
if Pass then
begin
// запретить кнопку тестирования (работает режим "психолог")
BBTest.Enabled := False;
// панель тестирования скрыть
PMainTest.Visible := False;
// панель тестирования "не распахивается"
PMainTest.Align := alNone;
// панель психолога показать
PMainPsy.Visible := True;
// перечитать запрос ПЭ на случай если был проведён ПЭ
// перед переходом в режим "психолог"
with DM.ADOQTesting do
begin
// деактивировать таблицу
Active := False;
// очистить запрос
SQL.Clear;
// вывести все данные
SQL.Add('SELECT * FROM Testing');
// активировать таблицу
Active := True;
end;
// панель психолога "распахнуть" на всё доступное пространство
PMainPsy.Align := alClient;
end
else
// пароль задан не правильно - режим активация режима тестирования
begin
// запретить кнопку тестирования (сброс "активного" состояния)
BBTest.Enabled := False;
// панель психолога скрыть
PMainPsy.Visible := False;
// панель психолога "не распахивается"
PMainPsy.Align := alNone;
// панель тестирования показать
PMainTest.Visible := True;
// панель тестирования "распахнуть" на всё доступное пространство
PMainPsy.Align := alClient;
// выбор статутса "тестирование"
RGStatus.ItemIndex := 0;
// ресондент в списоке респонденов не выбран
LBRespondent.ItemIndex := -1;
// тест в списке тестов не выбран
LBTest.ItemIndex := -1;
end;
end;
end;
end; // case
end;
end.
Соседние файлы в папке Курсовая ( Тест Томоса и узнавание фигур )