function GetPalette: PPalette; virtual; {изменениестандартнойпалитры}
end;
{ Русифицированная функция формирования сообщения }
function MyMessageBoxRect(var R: TRect;
const Msg: string; Params: pointer;
AOptions: word): word;
const
ButtonName: array[0..3] of string[6] = ('Ага', 'Нека', 'Ага', 'Нека');
Commands: array[0..3] of Word = (cmYes, cmNo, cmOK, cmCancel);
Titles: array[0..3] of string[11] =
('Предупреждение', 'Ошибка', 'Информация', 'Подтверждение');
var
I, X : integer;
Dialog : PDialog;
Control: PView;
S : string;
begin
Dialog:= New(PDialog, Init(R, Titles[AOptions and $3]));
with Dialog^ do
begin
Options:= Options or ofCentered;
R.Assign(3, 2, Size.X - 2, Size.Y - 3);
FormatStr(S, Msg, Params^);
Insert(New(PStaticText, Init(R, S)));
X:= -2;
R.Assign(0, 0, 10, 2);
for I:= 0 to 3 do
if AOptions and ($0100 shl I) <> 0 then
Inc(X, R.B.X - R.A.X + 2);
X:= (Size.X - X) shr 1;
for I:= 0 to 3 do
if AOptions and ($0100 shl I) <> 0 then
begin
Control:= New(PButton, Init(
R, ButtonName[I], Commands[i], bfNormal));
Insert(Control);
Control^.MoveTo(X, Size.Y - 3);
Inc(X, Control^.Size.X + 2);
end;
SelectNext(False);
end;
if AOptions and mfInsertInApp = 0 then
MyMessageBoxRect:= DeskTop^.ExecView(Dialog)
else
MyMessageBoxRect:= Application^.ExecView(Dialog);
Dispose(Dialog, Done);
end;
{ Русифицированная функция формирования сообщения
стандартногоразмера }
function MyMessageBox(const Msg: String;
Params: Pointer; AOptions: Word): Word;
var
R: TRect;
begin
R.Assign(0, 0, 40, 9);
MyMessageBox:= MyMessageBoxRect(R, Msg, Params, AOptions);
end;
function GetCurDir: DirStr;
var
CurDir: DirStr;
begin
GetDir(0, CurDir);
if Length(CurDir) > 3 then
begin
Inc(CurDir[0]);
CurDir[Length(CurDir)]:= '\';
end;
GetCurDir:= CurDir;
end;
{Процедура инициализации окна работы с файлами}
procedure TMyApp.FileOpen(WildCard: PathStr);
var
FileName: FNameStr;
begin
FileName:= '*.*';
if ExecuteDialog(New(PMyFileDialog, Init(
WildCard, 'Открытьфайл', 'Имя', fdOpenButton,
100)), @FileName) <> cmCancel then FName:=FileName;
{открыть файл, потом...}
end;
{****************************************************************************}
{*----------============= К Р И П Т О Г Р А Ф И Я ================----------*}
{****************************************************************************}
{Шифрованиефайлов}
procedure Shifr(InputFileName: string);
const
A = 5; {Константы для}
C = 27; {генератора}
M = 65536; {псевдослучайных чисел, далее - ПСЧ}
var
TempFile : file of byte;
InpF, OutF : file of word; {файлы на входе и выходе}
Password, Password1 : string; {переменные для работы с паролями}
OutputFileName, Exten : string; {переменныеименфайлов}
I, J, K, tmp : byte; {переменные кодирования}
Temp, SCode, TByte, Code: word;
Position : LongInt; {переменные данных о процессе}
NowPos : real;
TPassword : array [1..255] of word;
MasByte, Mas, MasEnd, PS: array [1..64] of word; {массивыперестановок}
T : array [0..64] of word;
DirInfo, DirInfo1 : SearchRec; {данныеофайле}
begin
if length(FName) > 3 then {Файлвыбран?}
begin
{Получить пароль}
Password := '';
Password1 := '';
InputBox('П А Р О Л Ь', ' Введите пароль:', Password, 255);
InputBox('П А Р О Л Ь', 'Введите пароль еще раз:', Password1, 255);
if (Password = Password1) and (length(Password)<>0) then
begin
{Преобразовать файл}
FindFirst(InputFileName, AnyFile, DirInfo);
if DOSError = 0 then
begin
if DirInfo.Size mod 2 = 1 then
begin
assign(TempFile, InputFileName);
reset(TempFile);
while not EOF(TempFile) do read(TempFile, tmp);
tmp := 255;
write(TempFile, tmp);
close(TempFile);
end;
{Преобразовать имя файла}
Position := 0;
assign(InpF, InputFileName);
reset(InpF);
for i := length(InputFileName) downto 1 do
if InputFileName[i] = '.' then
begin
OutputFileName := copy(InputFileName, 1, i) + 'M&A';
break;
end;
assign(OutF, OutputFileName);
rewrite(OutF);
for i:= 0 to length(InputFileName) do
if InputFileName[length(InputFileName) - i] = '.' then
case i of
0: Exten := chr(0) + chr(0) + chr(0);
1: Exten := copy(FName, length(FName)-2, i) + chr(0) + chr(0);
2: Exten := copy(FName, length(FName)-2, i) + chr(0)
else Exten := copy(FName, length(FName)-2, 3)
end;
for i := 1 to 3 do
begin
Temp := ord(Exten[i]);
Write(OutF, Temp);
end;
{Начать шифрование}
k := 1;
repeat
begin
{Считать из исходного файла блок размером 64*word}
for i:=1 to 64 do
If EOF(InpF) then MasByte[i] := 0 else Read(InpF, MasByte[i]);
Mas := MasByte;
T[0] := ord(Password[k]);
if k < length(Password) then inc(k) else k := 1;
for i:= 1 to 64 do
begin
{Получить текущую позицию процесса}
NowPos := 100*Position/DirInfo.Size;
inc(Position, 2);
if NowPos > 100 then NowPos := 100;
Str(Round(NowPos):3, Pos);
if OptInd = 0 then
begin
GoToXY(77, 1);
Write(Pos + '%');
end;
{Шифровать с помощью ПСЧ}
Code:=Mas[i];
T[i] := (A * T[i-1] + C) mod M;
Code:=T[i] xor Code;
Mas[i] := Code;
end;
for i:=1 to 8 do { Конечнаяперестановка }
for j:=1 to 8 do
case i of
1: MasEnd[8*(j-1)+i] := Mas[41-j];
2: MasEnd[8*(j-1)+i] := Mas[09-j];
3: MasEnd[8*(j-1)+i] := Mas[49-j];
4: MasEnd[8*(j-1)+i] := Mas[17-j];
5: MasEnd[8*(j-1)+i] := Mas[57-j];
6: MasEnd[8*(j-1)+i] := Mas[25-j];
7: MasEnd[8*(j-1)+i] := Mas[65-j];
8: MasEnd[8*(j-1)+i] := Mas[33-j]
end;
for i:= 1 to 64 do Write(OutF, MasEnd[i]);
end;
until eof(InpF);
MyMessageBox('Файл '+ InputFileName + ' зашифровансименем ' +
OutputFileName, nil, mfInformation+mfOkButton);
Close(InpF);
if OptFile = 1 then Erase(InpF);
Close(OutF);
end
else MyMessageBox('Файл '+ InputFileName + ' несуществует!',
nil, mfInformation+mfOkButton);
end
else MyMessageBox(' Ошибкавводапароля!!!', nil,
mfError+mfOkButton);
end
else MyMessageBox(' Файлневыбран!!!', nil, mfError+mfOkButton);
end;
procedure DeShifr(InputFileName: String);
const
A = 5;
C = 27;
M = 65536;
var
InpF, OutF : file of word;
Password, OutputFileName : string;
Password1 : string;
Exten : string[3];
SCode, Temp, Ext, TByte, Code: word;
I, J, K : byte;
Position : LongInt;
NowPos : real;
TPassword : array [1..255] of word;
MasByte, Mas, MasEnd, PS : array [1..64] of word;
T : array [0..64] of word;
DirInfo : SearchRec;
begin
if (length(InputFileName) > 3) and
(copy(InputFileName, length(InputFileName)-2, 3) = 'M&A') then
begin
Password := '';
Password1 := '';
InputBox('ПАРОЛЬ', ' Введитепароль:', Password, 255);
InputBox('П А Р О Л Ь', 'Введите пароль еще раз:', Password1, 255);
if (Password = Password1) and (length(Password)<>0) then
begin
FindFirst(InputFileName, AnyFile, DirInfo);
if DOSError = 0 then
begin
Assign(InpF, InputFileName);
Reset(InpF);
Position := 0;
Exten := '';
for i:= 1 to 3 do
begin
Read(InpF, Temp);
Exten := Exten + chr(Temp);
end;
for i := length(InputFileName) downto 1 do
if InputFileName[i] = '.' then
begin
OutputFileName := copy(InputFileName, 1, i) + Exten;
break;
end;
Assign(OutF, OutputFileName);
Rewrite(OutF);
for i := 1 to length(Password) do TPassword[i]:=ord(Password[i]);
k := 1;
repeat
begin
for i:=1 to 64 do Read(InpF, MasByte[i]);
for i:=1 to 8 do { начальная перестановка }
for j:=1 to 8 do
case i of
1: Mas[8*(i-1)+j]:=MasByte[66-8*j];
2: Mas[8*(i-1)+j]:=MasByte[68-8*j];
3: Mas[8*(i-1)+j]:=MasByte[70-8*j];
4: Mas[8*(i-1)+j]:=MasByte[72-8*j];
5: Mas[8*(i-1)+j]:=MasByte[65-8*j];
6: Mas[8*(i-1)+j]:=MasByte[67-8*j];
7: Mas[8*(i-1)+j]:=MasByte[69-8*j];
8: Mas[8*(i-1)+j]:=MasByte[71-8*j]
end;
T[0] := ord(Password[k]);
if k < length(Password) then inc(k) else k := 1;
for i:= 1 to 64 do
begin
NowPos := 100*Position/DirInfo.Size;
inc(Position, 2);
If NowPos > 100 then NowPos := 100;
Str(Round(NowPos):3, Pos);
if OptInd = 0 then
begin
GoToXY(77, 1);
Write(Pos + '%');
end;
T[i] := (A * T[i-1] + C) mod M;
Code:=Mas[i];
Code:=T[i] xor Code;
Mas[i] := Code;
end;
MasEnd := Mas;
for i := 1 to 64 do Write(OutF, MasEnd[i]);
end;
until eof(InpF);
GotoXY(77, 1);
write('100%');
MyMessageBox('Файл '+ InputFileName + ' расшифрованв ' +
OutputFileName, nil, mfInformation+mfOkButton);
Close(InpF);
if OptFile = 1 then Erase(InpF);
Close(OutF);
end
else MyMessageBox('Файл '+ InputFileName + ' несуществует!',
nil, mfInformation+mfOkButton);
end
else MyMessageBox(' Ошибкавводапароля!!!', nil,
mfError+mfOkButton);
end
else MyMessageBox(' Файлневыбран!!!', nil,
mfError+mfOkButton);
end;
{Опциикриптографии}
constructor TOptions.Init;
var
R : TRect;
Q, Q1: PView;
Butt : TRadioButtons;
begin
R.Assign(0, 0, 60, 11);
inherited Init(R, 'Криптография');
Options := Options or ofCentered;
R.Assign(10, 8, 20, 10);
Insert(New(PButton, Init(R, '~А~га', cmOK, bfDefault)));
R.Assign(40, 8, 50, 10);
Insert(New(PButton, Init(R, '~Н~ека', cmCancel, bfNormal)));
R.Assign(2, 2, 25, 3);
Insert(New(PLabel, Init(R, 'Исходныйфайл:', Q)));
R.Assign(5, 4, 21, 6);
Q:=New(PRadioButtons, Init(R,
NewSItem('~Н~еудалять',
NewSItem('~У~далять', nil))));
Insert(Q);
R.Assign(27, 2, 45, 3);
Insert(New(PLabel, Init(R, 'Индикатор:', Q1)));
R.Assign(30, 4, 50, 6);
Q1:=New(PRadioButtons, Init(R,
NewSItem('~В~ысвечивать',
NewSItem('~Н~евысвечивать', nil))));
Insert(Q1);
end;
{Изменение пароля на вход в систему}
procedure Passwords;
var
Ps, Ps1: string;
I : byte;
tmp : char;
begin
Ps := '';
Ps1 := '';
InputBox('П А Р О Л Ь', 'Введите пароль:', Ps, 255);
for i:= 1 to length(Ps) do Ps[i] :=chr(ord(Ps[i]) xor 27);
if Ps <> Pass then
begin
MyMessageBox(' Неверныйпароль!!!', nil, mfError+mfOkButton);
ClrScr;
writeln('Несанкционированный доступ!');
Halt;
end;
InputBox('И З М Е Н Е Н И Е П А Р О Л Я',
'Введите новый пароль:', Ps, 255);
InputBox('И З М Е Н Е Н И Е П А Р О Л Я',
' Повторите ввод:', Ps1, 255);
if (Ps = Ps1) and (Ps <> '') then
begin
Assign(FilePass, 'system.res');
Rewrite(FilePass);
for i := 1 to length(PS) do
begin
tmp := chr(ord(Ps[i]) xor 27);
Write(FilePass, tmp);
end;
Close(FilePass);
end
else MyMessageBox(' Ошибкавводапароля!!!', nil, mfError+mfOkButton);
end;
{Обработка ошибок}
procedure CheckExec;
var
St: string;
begin
Str(DOSError, St);
case DOSError of
2: MyMessageBox(' Ошибка DOS № ' +
St + ' "Файл не найден"',
nil, mfError + mfOkButton);
3: MyMessageBox(' Ошибка DOS № ' +
St + ' "Путь не найден"',
nil, mfError + mfOkButton);
5: MyMessageBox(' Ошибка DOS № ' +
St + '"Неверный код доступа к файлу"',
nil, mfError + mfOkButton);
6: MyMessageBox(' Ошибка DOS № ' +
St + '"Неверный код системного обработчика файла"',
nil, mfError + mfOkButton);
8: MyMessageBox(' Ошибка DOS № ' +
St + ' "Недостаточно памяти"',
nil, mfError + mfOkButton);
10: MyMessageBox(' Ошибка DOS № ' +
St + ' "Неверная среда"',
nil, mfError + mfOkButton);
11: MyMessageBox(' Ошибка DOS № ' +
St + ' "Неправильный формат"',
nil, mfError + mfOkButton);
18: MyMessageBox(' Ошибка DOS № ' +
St + '"Нет свободных обработчиков для файлов"',
nil, mfError + mfOkButton);
end;
end;
procedure MakeComFile(k: byte);
const
S : array [1..4] of string = ('c:\sub_rosa\plus.', 'c:\sub_rosa\passw.',
'c:\sub_rosa\block.', 'c:\sub_rosa\keydisk.');
Size : array [1..4] of word = (1068, 204, 617, 2118);
Inden: array [1..4, 1..3] of byte = ((ord('ы'), 26 , ord('Р')),
(ord('ы'), 39 , ord('Р')),
(ord('щ'), ord('Й'), ord('_')),
(ord('щ'), ord('А'), ord('_')));
var
I, Tmp : byte;
F : array [1..4, 1..2] of file ;
M : array [1..2200] of byte ;
NumRead, NumWritten: Word;
begin
assign(F[k, 1], S[k]); reset(F[k, 1], 1);
assign(F[k, 2], S[k]+'com'); rewrite(F[k, 2], 1);
for i := 1 to 3 do
begin
BlockRead(F[k, 1], tmp, 1, NumRead);
BlockWrite(F[k, 2], Inden[k, i], 1, NumWritten);
end;
BlockRead(F[k, 1], M, Size[k]-3, NumRead);
BlockWrite(F[k, 2], M, Size[k]-3, NumWritten);
close(F[k, 1]); close(F[k, 2]);
end;
procedure DelComFile(k: byte);
const
{ S: array [1..4] of string =
('plus.com', 'passw.com', 'block.com', 'keydisk.com');}
S : array [1..4] of string = ('c:\sub_rosa\plus.com',
'c:\sub_rosa\passw.com',
'c:\sub_rosa\block.com',
'c:\sub_rosa\keydisk.com');
var
F: array [1..4] of file;
begin
Assign(F[k], S[k]);
Erase(F[k]);
end;
{****************************************************************************}
{*----------=========== Д О П И С А Т Ь К Ф А Й Л У ==========----------*}
{****************************************************************************}
procedure Plus(WhatDo: string);
var
FileStr, Err: string;
CmdLine : string;
I : byte;
FileName : FNameStr;
Regs : Registers;
begin
{Проверка условий}
if Length(FName) > 3 then
begin
if (copy(FName, length(FName)-2, 3) = 'EXE') or
(copy(FName, length(FName)-2, 3) = 'COM')