end;
ErrTeachersListLoad:
begin
SMessage ('Base read teachers error');
end;
ErrImputWorkNumberFault:
SMessage ('Imput work number fault');
ErrImputTeacherNumberFault:
SMessage ('Imput work number fault');
ErrQuestionsNotFound:
SMessage ('No questions found in base');
ErrConfigIniFileWorkSetNotFound:
SMessage ('Config file WorkSet.ini not found');
ErrReadBuiletNumber:
SMessage ('Error with read number of builet');
ErrQuestionWithInputedNumberNotFound:
SMessage ('Direstory with inputed number (QuestionNum) is not found (number out of range)');
ErrQuestionFileWithInputedNumberNotFound:
SMessage ('File with inputed number (QuestionName) is not found (number out of range)');
ErrInSelectedDirectoryNotQuestFileNameFound:
SMessage ('In the selected tirectory question file is not found');
ErrGenerationRndQuest:
SMessage ('Error by generation random question file maybe question directory is not found');
ErrInvalidFileNameTraslate:
SMessage ('Invalid Translate question name filename STR to INT maybe filename error');
end;
end;
Procedure TQuestDB.SMessage (Message_:string);
begin
SendMessage (SelfParent, WM_User+2, DWord (PChar(TransactionUser+' '+Message_)), 0);
end;
/////////////////QUESTIONS ////////////////
function TQuestDB. UpdateQuestionsSet:boolean;
var QCount:integer;
EnumFileDir:TSearchRec;
FOptions:TIniFile;
TryConvert:TDateTime;
WorkTimeLim:string;
begin
QuestionsPathName:=ProgRootDir+'\Questions\'+ActiveWork+'\'+ActiveTeacher;
try
try
FOptions:=TIniFile. Create (QuestionsPathName+'\WorkSet.ini');
QuestCount:=FOptions. ReadInteger ('QuestionCount', 'value', – 1);
WorkTimeLim:=FOptions. ReadString ('TimeForWork', 'value', '0:00:00');
TryConvert:=StrToTime(WorkTimeLim);
WorkTimeLimit_:=WorkTimeLim;
ImgType:=FOptions. ReadString ('ImgType', 'value', 'bmp');
FOptions. Destroy;
finally
if QuestCount>0 then result:=true else result:=false;
end;
except
result:=false;
end;
end;
function TQuestDB. ConverHLrToIntNum (StringNum:string):integer;
var ProtectAssign:integer;
begin
if TestByDigit(StringNum) then
begin
ProtectAssign:=StrToInt(StringNum);
result:=ProtectAssign;
end else
begin
ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrReadBuiletNumber);
result:=-1;
end;
end;
function TQuestDB. TestByDigit (DataString:string):boolean;
var DataLen:byte;
Offs:byte;
begin
Result:=true;
DataLen:=Length(DataString);
for Offs:=1 to DataLen do
if not (DataString[Offs] in ['0'..'9']) then
begin
result:=false;
break;
end;
end;
function TQuestDB. GetBuiletByNum (Num:integer):string;
var EnumBuiletsFile:TSearchRec;
StringBuiletNum:string;
begin
Result:='';
FindFirst (QuestionsPathName+'\*', faDirectory, EnumBuiletsFile);
repeat
if EnumBuiletsFile. Name[1]<>'.' then
begin
StringBuiletNum:=EnumBuiletsFile. Name;
if TestByDigit(StringBuiletNum) then
if ConverHLrToIntNum(StringBuiletNum)=Num then
begin
result:=QuestionsPathName+'\'+EnumBuiletsFile. Name;
break;
end;
end;
until FindNext(EnumBuiletsFile)<>0;
FindClose(EnumBuiletsFile);
If Result='' then ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrQuestionWithInputedNumberNotFound);
end;
function TQuestDB. GetFileBuiletByNumBuilet (BuiletNum, FileNum:integer):string;
var EnumBuiletsNamesFile:TSearchRec;
StringBuiletNum:string;
begin
Result:='';
FindFirst (QuestionsPathName+'\'+IntToStr(BuiletNum)+'\*', faAnyFile, EnumBuiletsNamesFile);
repeat
if EnumBuiletsNamesFile. Name[1]<>'.' then
begin
StringBuiletNum:=EnumBuiletsNamesFile. Name;
Delete (StringBuiletNum, Length(StringBuiletNum) – 3,4);
if TestByDigit(StringBuiletNum) then
if ConverHLrToIntNum(StringBuiletNum)=FileNum then
begin
result:=QuestionsPathName+'\'+EnumBuiletsNamesFile. Name;
break;
end;
end;
until FindNext(EnumBuiletsNamesFile)<>0;
FindClose(EnumBuiletsNamesFile);
If Result='' then ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrQuestionFileWithInputedNumberNotFound);
end;
function TQuestDB. GetRandomFileBuilet (BuiletNum:integer):string;
var EnumBuiletsNamesFile:TSearchRec;
RndCount:integer;
FileList:HLringList;
WorkPath:string;
begin
Result:='';
FileList:=HLringList. Create;
FileList. Clear;
WorkPath:=QuestionsPathName+'\'+IntToStr(BuiletNum);
if DirectoryExists(WorkPath) then
begin
FindFirst (WorkPath+'\*', faAnyFile, EnumBuiletsNamesFile);
repeat
if EnumBuiletsNamesFile. Name[1]<>'.' then
FileList. Add (EnumBuiletsNamesFile. Name);
until FindNext(EnumBuiletsNamesFile)<>0;
FindClose(EnumBuiletsNamesFile);
if FileList. Count>0 then
begin
Randomize;
RndCount:=Random (FileList. Count);
Result:=QuestionsPathName+'\'+IntToStr(BuiletNum)+'\'+FileList. Strings[RndCount];
end;
end;
FileList. Destroy;
If Result='' then ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrGenerationRndQuest);
end;
function TQuestDB. GetTrueAnswerForBuilet (QuestionPath:string):integer;
var QuestNum:integer;
TmpStr:string;
KeyFilePath:string;
TempQuestionsList:HLringList;
begin
Result:=-1;
QuestNum:=0;
TmpStr:=ExtractFileName(QuestionPath);
Delete (TmpStr, Length(TmpStr) – Length (ExtractFileExt(TmpStr))+1, Length (ExtractFileExt(TmpStr)));
if (TestByDigit(TmpStr)) and (Length(TmpStr)<5) then
begin
QuestNum:=StrToInt(TmpStr);
end else
begin
ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrInvalidFileNameTraslate);
Result:=-1;
exit;
end;
KeyFilePath:=ExtractFilePath (ExtractFileDir(QuestionPath))+'QuestKey.ini';
if FileExists(KeyFilePath) then
begin
TempQuestionsList:=HLringList. Create;
TempQuestionsList. LoadFromFile(KeyFilePath);
Result:=StrToInt (TempQuestionsList. Strings[QuestNum]);
TempQuestionsList. Destroy;
end else ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrConfigIniFileWorkSetNotFound);
end;
function TQuestDB. SetTrueAnswerForBuilet (QuestionPath:string; TrueAnswer: Integer):boolean;
var QuestNum:integer;
TmpStr:string;
KeyFilePath:string;
TempQuestionsList:HLringList;
begin
Result:=false;
QuestNum:=0;
TmpStr:=ExtractFileName(QuestionPath);
Delete (TmpStr, Length(TmpStr) – Length (ExtractFileExt(TmpStr))+1, Length (ExtractFileExt(TmpStr)));
if (TestByDigit(TmpStr)) and (Length(TmpStr)<5) then
begin
QuestNum:=StrToInt(TmpStr);
end else ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrInvalidFileNameTraslate);
KeyFilePath:=ExtractFilePath (ExtractFileDir(QuestionPath))+'QuestKey.ini';
if FileExists(KeyFilePath) then
begin
TempQuestionsList:=HLringList. Create;
TempQuestionsList. LoadFromFile(KeyFilePath);
TempQuestionsList. Strings[QuestNum]:=IntToStr(TrueAnswer);
TempQuestionsList. SaveToFile (KeyFilePath+'_');
TempQuestionsList. Destroy;
DeleteFile(KeyFilePath);
RenameFile (KeyFilePath+'_', KeyFilePath);
Result:=true;
end else ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrConfigIniFileWorkSetNotFound);
end;
end.
unit UBaseWork;
interface
uses Windows, Messages, SysUtils, Classes, Dialogs, IniFiles;
const
ErrImputGroupNumberFault = 1;
ErrImputUserNumberFault = 2;
type
UsersDBase=record
Groups:HLringList;
Users:array of HLringList;
end;
type
TUsersDB = class
private
SelfParent:HWND;
UsersDataBase: UsersDBase;
GroupsCount:integer;
ProgRootDir:string;
ActiveGroup:string;
ActiveUser:string;
ActivStationIP:string;
ActiveGroupNum:byte;
ActiveUserNum:byte;
procedure ERROR_MESSAGE_FOR_DEBUG_LEVEL (ErrID: byte);
procedure SMessage (Message_: string);
public
property TransactionIP:string read ActivStationIP write ActivStationIP;
property ActiveUserName:string read ActiveUser;
property ActiveGroupName:string read ActiveGroup;
function SetActiveGroup (Num: byte): boolean;
function SetActiveUser (Num: byte): boolean;
function GetGroupByIndex (i: byte): string;
function GetUserByIndex (i: byte): string;
function GetGroupsStringList: string;
function GetUsersStringList: string;
constructor Create (ParentHwnd:HWND);
destructor Destroy; override;
end;
implementation
{TQuestDB}
constructor TUsersDB. Create (ParentHwnd: HWND);
var ExeName:PChar;
AppName: String;
ExeNameLen:byte;
/////
NewSearch_:TSearchRec;
CleanName:string;
i:byte;
begin
SelfParent:=ParentHwnd;
GetMem (ExeName, 255);
ExeNameLen:=255;
GetModuleFileName (0, ExeName, ExeNameLen); // определяем имя исполняемого модуля
AppName:=StrPas(ExeName);
ProgRootDir:=ExtractFileDir(AppName);
GroupsCount:=0;
UsersDataBase. Groups:=HLringList. Create;
FindFirst (ProgRootDir+'\Groups\*', faDirectory, NewSearch_);
repeat
if NewSearch_.Name[1]<>'.' then
begin
UsersDataBase. Groups. Add (NewSearch_.Name);
inc(GroupsCount);
end;
until FindNext (NewSearch_)<>0;
FindClose (NewSearch_);
SetLength (UsersDataBase. Users, GroupsCount);
for i:=0 to GroupsCount-1 do
begin
UsersDataBase. Users[i]:=HLringList. Create;
UsersDataBase. Users[i].LoadFromFile (ProgRootDir+'\Groups\'+UsersDataBase. Groups. Strings[i]);
CleanName:=UsersDataBase. Groups. Strings[i];
Delete (CleanName, Length(CleanName) – 3,4);
UsersDataBase. Groups. Strings[i]:=CleanName;
end;
end;
destructor TUsersDB. Destroy;
var i:integer;
begin
for i:=0 to UsersDataBase. Groups. Count-1 do
begin
UsersDataBase. Users[i].Destroy;
end;
SetLength (UsersDataBase. Users, 0);
UsersDataBase. Groups. Destroy;
inherited;
end;
function TUsersDB. SetActiveGroup (Num:byte):boolean;
begin
result:=false;
if Num< UsersDataBase. Groups. Count then
begin
ActiveGroup:=UsersDataBase. Groups. Strings[Num];
ActiveGroupNum:=Num;
result:=true;
end else ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrImputGroupNumberFault);
end;
function TUsersDB. SetActiveUser (Num:byte):boolean;
begin
result:=false;
if Num< UsersDataBase. Users[ActiveGroupNum].Count then
begin
ActiveUser:=UsersDataBase. Users[ActiveGroupNum].Strings[num];
ActiveUserNum:=Num;
result:=true;
end else ERROR_MESSAGE_FOR_DEBUG_LEVEL(ErrImputUserNumberFault);
end;
procedure TUsersDB.ERROR_MESSAGE_FOR_DEBUG_LEVEL (ErrID: byte);
begin
Case ErrID of
ErrImputGroupNumberFault:
SMessage ('Imput group number fault');
ErrImputUserNumberFault:
SMessage ('Imput user number fault');
end;
end;
Procedure TUsersDB.SMessage (Message_:string);
begin
SendMessage (SelfParent, WM_User+2, DWord (PChar(ActivStationIP+' '+Message_)), 0);
end;
function TUsersDB. GetGroupByIndex (i:byte): string;
begin
if i<=UsersDataBase. Groups. Count-1 then Result:=UsersDataBase. Groups. Strings[i] else Result:='';
end;
function TUsersDB. GetUserByIndex (i:byte): string;
begin
if i<=UsersDataBase. Users[ActiveGroupNum].Count-1 then
Result:=UsersDataBase. Users[ActiveGroupNum].Strings[i] else Result:='';
end;
function TUsersDB. GetGroupsStringList: string;
var i:integer;
begin
Result:='';
for i:=0 to UsersDataBase. Groups. Count-1 do Result:=Result+UsersDataBase. Groups. Strings[i]+'|';
Result:=Result+'>';
end;
function TUsersDB. GetUsersStringList: string;
var i:integer;
begin
Result:='';
for i:=0 to UsersDataBase. Users[ActiveGroupNum].Count-1 do Result:=Result+UsersDataBase. Users[ActiveGroupNum].Strings[i]+'|';
Result:=Result+'>';
end;
end.
unit Registation;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
HLartForm = class(TForm)
Panel2: TPanel;
ComboBox3: TComboBox;
ComboBox4: TComboBox;
Label5: TLabel;
Label6: TLabel;
Bevel2: TBevel;
Bevel3: TBevel;
Panel1: TPanel;
Bevel4: TBevel;
Bevel5: TBevel;
Label3: TLabel;
Label4: TLabel;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
Bevel6: TBevel;
Bevel7: TBevel;
Panel3: TPanel;
Bevel1: TBevel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Panel4: TPanel;
procedure ComboBox1Change (Sender: TObject);
procedure Button2Click (Sender: TObject);
procedure Button1Click (Sender: TObject);
procedure Button3Click (Sender: TObject);
procedure ComboBox3Change (Sender: TObject);
procedure ComboBox2Change (Sender: TObject);
procedure FormClose (Sender: TObject; var Action: TCloseAction);
private
ServerIPAddress:string[15]; //IP адрес
Steps:byte; // номер шага регистрации (условно)
NoModify:boolean; // триггер интерфейса
function ReadServerIP: string; // чтение из файла IP.DAT информации о IP адресе сервера
public
procedure GetConnect; // Установка соединение
procedure HideWin_(YN: boolean); // скрыть элементы управления Windows (TaskBar, Deskdop)
procedure ExitProgram;
end;
var
StartForm: HLartForm;
implementation
uses MainForm;
{ /////////////////////////////////////////////////////
BEGIN
Сервисные подпрограммы
////////////////////////////////////////////////////// }
function HLartForm. ReadServerIP: string;
var IPInfFile:textfile;
IP:string;
begin
if fileexists (extractfilepath(application. ExeName)+'IP. Dat') then
begin
assignfile (IPInfFile, extractfilepath (application. ExeName)+'IP. Dat');
{$i-}
reset(IPInfFile);
Readln (IPInfFile, IP);
closefile(IPInfFile);
{$i+}
if ip<>'' then
begin
ReadServerIP:=IP;
end
else ReadServerIP:='127.0.0.1';
end else
begin
ReadServerIP:='127.0.0.1';
end;
end;
procedure HLartForm. HideWin_(YN:boolean);
var Wnd: hWnd;
ClassName:PChar;
ClassNameLen:byte;
Res:string;
begin
Wnd:=FindWindow ('Progman', 'Program Manager');
while wnd<>0 do
begin
wnd:=GetWindow (Wnd, GW_CHILD);
ClassNameLen:=0;
GetClassName (Wnd, ClassName, ClassNameLen);
SeHLring (Res, ClassName, ClassNameLen);
SeHLring (Res, ClassName, StrLen(ClassName));
if Res='SysListView32' then
begin
if YN=true then
begin
ShowWindow (Wnd, SW_Hide);
ShowWindow (findwINDOW('Shell_TrayWnd', nil), SW_Hide);
end else
begin
ShowWindow (Wnd, SW_Show);
ShowWindow (findwINDOW('Shell_TrayWnd', nil), SW_Show);
end;
break;
end;
end;
FreeMem (ClassName, 255);
end;
procedure HLartForm. ExitProgram;
begin
HideWin_(false);
Application. ProcessMessages;
Application. Terminate;
end;
{ /////////////////////////////////////////////////////
Сервисные подпрограммы
END
////////////////////////////////////////////////////// }
{ /////////////////////////////////////////////////////
BEGIN
Сетевые подпрограммы
////////////////////////////////////////////////////// }
procedure HLartForm. GetConnect;