dialog.pas

文件加密发生法

unit Dialog;

interface

uses
  Windows, SysUtils, Messages, Forms, Controls, StdCtrls, Classes;

const
  PassSize=18;
  CFlag='...FILE..LOCK...';

type
  TLockedFile=record
    Flag:String[Length(CFlag)];
    PassWord:String[PassSize];
    Caption:String[52];
    Compressed:Boolean;
  end;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
  private
    ExtFName,ParamsFName:String;
    CheckTimes:Byte;
    iFile:Integer;
    LockedFile:TLockedFile;
    procedure WMSysCommand(var Message: TWMSysCommand); message wm_SysCommand;
    function WinExecAndWait32(bWait:Boolean;FName:String;Visibility:Integer):Cardinal;
    procedure PutLockFile;
//    function GetTempDirectory: String;
    function AddParams(FName: String):String;
    { Private declarations }
  public
    { Public declarations }
  end;

const
  Ver='2.11';

  FileExeEnd=$21000;

  Error_PassWrong='输入密码错误->还有0%d次机会';
  Error_Flag='加密标志错误->文件可能损坏';
  Error_Runing='程序在运行中->无法建立副本';
  Msg_Locking='正在解密中……请稍后';

  cm_About=$00A0;

const
  RSP_SIMPLE_SERVICE     = $00000001;
  RSP_UNREGISTER_SERVICE = $00000000;

var
  Form1: TForm1;

implementation

uses Encrypt_Base64, Compress_LH5;

{$R *.DFM}    

function RegisterServiceProcess(dwProcessId, dwServiceType: DWord): DWord; stdcall;
         external 'Kernel32.dll' Name 'RegisterServiceProcess';

function TForm1.WinExecAndWait32(bWait:Boolean;FName:String;Visibility:Integer):Cardinal;
var
  WorkDir:PChar;
  StartupInfo:TStartupInfo;
  ProcessInfo:TProcessInformation;
begin
  WorkDir:=PChar(ExtractFileDir(ParamStr(0)));
  FillChar(StartupInfo,Sizeof(StartupInfo),#0);
  StartupInfo.cb:=Sizeof(StartupInfo);
  StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow:=Visibility;
  if not CreateProcess(nil,
    PChar(FName),                  { pointer to command line string }
    nil,                           { pointer to process security attributes }
    nil,                           { pointer to thread security attributes }
    True,                          { handle inheritance flag }
    CREATE_NEW_CONSOLE or          { creation flags }
    NORMAL_PRIORITY_CLASS,
    nil,                           { pointer to new environment block }
    WorkDir,                       { pointer to current directory name, PChar}
    StartupInfo,                   { pointer to STARTUPINFO }
    ProcessInfo)                   { pointer to PROCESS_INF }
  then Result:=INFINITE else
  begin
    if not bWait then exit;

    Hide;
    iFile:=FileOpen(ExtFName,fmShareExclusive);

    Application.ProcessMessages;
    WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess, Result);
    CloseHandle(ProcessInfo.hProcess);  { to prevent memory leaks }
    CloseHandle(ProcessInfo.hThread);

    FileClose(iFile);
    Close;                              { exit application }
  end;
end;

procedure TForm1.PutLockFile;
var
  S,T,C:TMemoryStream;
begin
  S:=TMemoryStream.Create;
  T:=TMemoryStream.Create;
  C:=TMemoryStream.Create;
  try
    S.LoadFromFile(ParamStr(0));
    S.Position:=FileExeEnd;
    T.Position:=0;
    Application.ProcessMessages;
    if LockedFile.Compressed then
    begin
      C.Position:=0;
      C.CopyFrom(S,S.Size-FileExeEnd-SizeOf(LockedFile));
      C.Position:=0;
      LHAExpand(C,T);
    end else T.CopyFrom(S,S.Size-FileExeEnd-SizeOf(LockedFile));
    Application.ProcessMessages;
    T.SaveToFile(ExtFName);
    FileSetAttr(ExtFName,faHidden);
  finally
    S.Free;
    T.Free;
    C.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Close;
end;

function TForm1.AddParams(FName:String):String;
var
  iParam:Byte;
begin
  if ParamCount>0 then
  begin
    Result:=Format('"%s"',[FName]);
    for iParam:=1 to ParamCount do
      Result:=Result+' "'+ParamStr(iParam)+'"';
  end else Result:=FName;
end;

function RunLockFile(P:pointer):Longint;stdcall;
begin
  with Form1 do
  begin
    Label1.Caption:=Msg_Locking;
    Button1.Enabled:=False;
    Application.ProcessMessages;
    PutLockFile;
  end;
  Result:=-1;
end;

procedure TForm1.Button1Click(Sender: TObject);
{var
  hThread:Thandle;
  ThreadID:DWord; }
begin
  if LockedFile.Flag<>CFlag then
  begin
    label1.Caption:=Error_Flag;
    Exit;
  end;
  if Base64Decode(LockedFile.PassWord)<>Edit1.Text then
  begin
    { check password times }
    inc(CheckTimes);
    if CheckTimes>3 then Close else
    begin
      Label1.Caption:=Format(Error_PassWrong,[4-CheckTimes]);
      Edit1.Text:='';
      Edit1.SetFocus;
    end;
  end else
  begin
    DeleteFile(ExtFName);
    if FileExists(ExtFName) then
    begin
//      MessageBox(Handle,PChar(ParamsFName),'',MB_OK);
      WinExec(PChar(ParamsFName),SW_NORMAL);
      Close;
    end else
    begin
//      MessageBox(Handle,PChar(ParamsFName),'',MB_OK);
      RunLockFile(nil);
      WinExecAndWait32(True,ParamsFName,SW_NORMAL);
    end;
  end;
end;

{function TForm1.GetTempDirectory: String;
var
  TempDir:array[0..255] of Char;
begin
  GetTempPath(255,@TempDir);
  Result:=StrPas(TempDir);
end;  }

procedure TForm1.FormCreate(Sender: TObject);
var
  MyMenu:HMenu;
begin
  Caption:=Application.Title;
  MyMenu:=GetSystemMenu(Handle,False);
  AppendMenu(MyMenu,MF_STRING,cm_About,'关于(&A)');
  CheckTimes:=1;
  ExtFName:=ChangeFileExt(ParamStr(0),'.LCK');
  ParamsFName:=AddParams(ExtFName);
  try
//    RegisterServiceProcess(0,RSP_SIMPLE_SERVICE);
  except
  end; 
//  Caption:=ParamsFName;
end;
             
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  { delete tmpfile }
  DeleteFile(ExtFName);
end;

procedure TForm1.WMSysCommand(var Message: TWMSysCommand);
begin { about messagedlg }
  case Message.CmdType of
    cm_About:MessageBox(Handle,
                        '作  者：万  重'+#13
                       +'版  本：'+Ver+#13
                       +'主  页：mantousoft.51.net'+#13
                       +'邮  箱：[e-mail]',
                        '关于',
                        MB_ICONINFORMATION OR MB_OK)
  else
    inherited;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  iFile:=FileOpen(ParamStr(0),fmOpenRead or fmShareDenyNone);
  try
    FileSeek(iFile,-SizeOf(LockedFile),2);
    FileRead(iFile,LockedFile,SizeOf(LockedFile));
    Label1.Caption:=LockedFile.Caption;
  finally
    FileClose(iFile);
  end;
end;

end.