umain.pas

电脑锁定

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, JPEG, StdCtrls, ExtCtrls, Registry, ShellAPI;

const
  InputBoxMessage = WM_USER + 200;

type
  TfrmMain = class(TForm)
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    fBackground : TPicture;
    { Private declarations }
    procedure CheckForBackground;
    procedure InputBoxSetPasswordChar(var Msg: TMessage); message InputBoxMessage;
  public
    MD5Password : String;
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  function MD5(const Input: String): String;

implementation

uses uLogin, uLockHook;

{$R *.dfm}

const
  ADVAPI32    = 'advapi32.dll';
  function CryptAcquireContext(phProv: PULONG; pszContainer: PAnsiChar; pszProvider: PAnsiChar; dwProvType: DWORD; dwFlags: DWORD): BOOL; stdcall; external ADVAPI32 name 'CryptAcquireContextA';
  function CryptCreateHash(hProv: ULONG; Algid: ULONG; hKey: ULONG; dwFlags: DWORD; phHash: PULONG): BOOL; stdcall; external ADVAPI32 name 'CryptCreateHash';
  function CryptHashData(hHash: ULONG; const pbData: PBYTE; dwDataLen: DWORD; dwFlags: DWORD): BOOL; stdcall; external ADVAPI32 name 'CryptHashData';
  function CryptGetHashParam(hHash: ULONG; dwParam: DWORD; pbData: PBYTE; pdwDataLen: PDWORD; dwFlags: DWORD): BOOL; stdcall; external ADVAPI32 name 'CryptGetHashParam';
  function CryptDestroyHash(hHash: ULONG): BOOL; stdcall; external ADVAPI32 name 'CryptDestroyHash';
  function CryptReleaseContext(hProv: ULONG; dwFlags: DWORD): BOOL; stdcall; external ADVAPI32 name 'CryptReleaseContext';

function MD5(const Input: String): String;
const
  HP_HASHVAL = $0002;
  PROV_RSA_FULL  = 1;
  CRYPT_VERIFYCONTEXT = $F0000000;
  CRYPT_MACHINE_KEYSET = $00000020;
  ALG_CLASS_HASH = (4 SHL 13);
  ALG_TYPE_ANY = 0;
  ALG_SID_MD5 = 3;
  CALG_MD5 = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5);
var
  hCryptProvider : ULONG;
  hHash : ULONG;
  bHash : Array[0..$7F] Of Byte;
  dwHashLen : DWORD;
  pbContent : PByte;
  I : Integer;
begin
  dwHashLen := 16;
  pbContent := Pointer(PChar(Input));
  Result := '';
  If CryptAcquireContext(@hCryptProvider,nil,nil,PROV_RSA_FULL,CRYPT_VERIFYCONTEXT Or CRYPT_MACHINE_KEYSET) Then
    begin
    If CryptCreateHash(hCryptProvider,CALG_MD5,0,0,@hHash) Then
      begin
      If CryptHashData(hHash,pbContent,Length(Input),0) Then
        begin
        If CryptGetHashParam(hHash,HP_HASHVAL,@bHash[0],@dwHashLen,0) Then
          begin
          For I := 0 To dwHashLen - 1 Do
            begin
            Result := Result + Format('%.2x',[bHash[I]]);
          end;
        end;
      end;
      CryptDestroyHash(hHash);
    end;
    CryptReleaseContext(hCryptProvider, 0);
  end;
  Result := AnsiLowerCase(Result);
end;

procedure TfrmMain.InputBoxSetPasswordChar(var Msg: TMessage);
var
  hInputForm,
  hEdit : HWND;
begin
  hInputForm := Screen.Forms[0].Handle;
  If (hInputForm <> 0) Then
    begin
    hEdit := FindWindowEx(hInputForm,0,'TEdit',nil);
    SendMessage(hEdit,EM_SETPASSWORDCHAR,Ord('*'),0);
  end;
end;

procedure TfrmMain.CheckForBackground;
const
  WPS_Tile = 0;
  WPS_Center = 1;
  WPS_SizeToFit = 2;
var
  FileName : String;
  Bitmap : TBitmap;
  JPEG : TJPEGImage;
  Reg : TRegistry;
  WallpaperStyle : Integer;
  X, Y : Integer;
  sRGB : String;
  R, G, B : Byte;
  BackgroundColor : TColor;
begin
  If FileExists('Background.bmp') Then
    begin
    fBackground := TPicture.Create;
    Try
      fBackground.LoadFromFile('Background.bmp');
    Except
      FreeAndNil(fBackground);
    end;
  end
  Else If FileExists('Background.jpg') Then
    begin
    fBackground := TPicture.Create;
    Try
      fBackground.LoadFromFile('Background.jpg');
    Except
      FreeAndNil(fBackground);
    end;
  end
  Else If FileExists('Background.jpeg') Then
    begin
    fBackground := TPicture.Create;
    Try
      fBackground.LoadFromFile('Background.jpeg');
    Except
      FreeAndNil(fBackground);
    end;
  end
  Else
    begin
    Reg := TRegistry.Create;
    Try
      Reg.RootKey := HKEY_CURRENT_USER;
      If Reg.OpenKeyReadOnly('Control Panel\Desktop') Then
        begin
        FileName := LowerCase(Reg.ReadString('Wallpaper'));
        If FileExists(FileName) Then
          begin
          Bitmap := TBitmap.Create;
          Try
            If (ExtractFileExt(FileName) = '.jpeg') Or (ExtractFileExt(FileName) = '.jpg') Then
              begin
              JPEG := TJPEGImage.Create;
              Try
                JPEG.LoadFromFile(FileName);
                Bitmap.Width := JPEG.Width;
                Bitmap.Height := JPEG.Height;
                Bitmap.Canvas.Draw(0,0,JPEG);
              Finally
                JPEG.Free;
              end;
            end
            Else If ExtractFileExt(FileName) = '.bmp' Then
              begin
              Bitmap.LoadFromFile(FileName);
            end;
            WallPaperStyle := StrToIntDef(Reg.ReadString('WallpaperStyle'),0);
            If WallPaperStyle = 0 Then
              begin
              If Reg.ReadString('TileWallpaper') = '0' Then WallPaperStyle := 1;
            end;
            fBackground := TPicture.Create;
            Try
              fBackground.Bitmap.Width := Screen.Width;
              fBackground.Bitmap.Height := Screen.Height;
              Case WallPaperStyle Of
                WPS_Tile:
                  begin
                  For X := 0 To (fBackground.Width div Bitmap.Width) Do
                    begin
                    For Y := 0 To (fBackground.Height div Bitmap.Height) Do
                      begin
                      fBackground.Bitmap.Canvas.Draw(X * Bitmap.Width,Y * Bitmap.Height,Bitmap);
                    end;
                  end;
                end;
                WPS_Center:
                  begin
                  Reg.CloseKey;
                  If Reg.OpenKeyReadOnly('Control Panel\Colors') Then
                    begin
                    sRGB := Reg.ReadString('Background');
                    R := StrToIntDef(Copy(sRGB,1,Pos(#32,sRGB) - 1),0);
                    sRGB := Copy(sRGB,Pos(#32,sRGB) + 1,Length(sRGB));
                    G := StrToIntDef(Copy(sRGB,1,Pos(#32,sRGB) - 1),0);
                    sRGB := Copy(sRGB,Pos(#32,sRGB) + 1,Length(sRGB));
                    B := StrToIntDef(sRGB,0);
                    BackgroundColor := RGB(R,G,B);
                    fBackground.Bitmap.Canvas.Brush.Color := BackgroundColor;
                    fBackground.Bitmap.Canvas.FillRect(fBackground.Bitmap.Canvas.ClipRect);
                    fBackground.Bitmap.Canvas.Draw((fBackground.Bitmap.Width div 2) - (Bitmap.Width div 2),(fBackground.Bitmap.Height div 2) - (Bitmap.Height div 2),Bitmap);
                  end;
                end;
                WPS_SizeToFit:
                  begin
                  fBackground.LoadFromFile(FileName);
                end;
              end;
            Except
              FreeAndNil(fBackground);
            end;
          Finally
            FreeAndNil(Bitmap);
          end;
        end;
      end;
    Finally
      Reg.CloseKey;
      FreeAndNil(Reg);
    end;
  end;
end;

procedure EnableTaskMan(Enable: Boolean);
const
  sRegPolicies = '\Software\Microsoft\Windows\CurrentVersion\Policies';
begin
 With TRegistry.Create Do
  Try
    RootKey := HKEY_CURRENT_USER;
    If OpenKey(sRegPolicies + '\System\',True) Then
      begin
      Case Enable Of
        False: WriteInteger('DisableTaskMgr',1);
        True: WriteInteger('DisableTaskMgr',0);
      end;
    end;
    CloseKey;
    If OpenKey(sRegPolicies + '\Explorer\',True) Then
      begin
      Case Enable of
        False:
          begin
          WriteInteger('NoChangeStartMenu',1);
          WriteInteger('NoClose',1);
          WriteInteger('NoLogOff',1);
        end;
        True:
          begin
          WriteInteger('NoChangeStartMenu',0);
          WriteInteger('NoClose',0);
          WriteInteger('NoLogOff',0);
        end;
      end;
    end;
  CloseKey;
  Finally
    Free;
  end;
end;

procedure RunOnWinStart(AppTitle, AppPathFile: String; RunOnce: Boolean; Delete: Boolean);
var
  Reg : TRegistry;
  TheKey : String;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;
  TheKey := 'Software\Microsoft\Windows\CurrentVersion\Run';
  If RunOnce Then TheKey := TheKey + 'Once';
  Reg.OpenKey(TheKey,True);
  If Not Delete Then
    begin
    Reg.WriteString(AppTitle,AppPathFile);
  end
  Else
    begin
    Reg.DeleteValue(AppTitle);
  end;
  Reg.CloseKey;
  Reg.Free;
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  RunOnWinStart('Computer Lock',ParamStr(0),True,True);
  EnableTaskMan(True);
  UnhookIt;
  If fBackground <> nil Then
    begin
    FreeAndNil(fBackground);
  end;
  Width := Width - 1;
  Height := Height - 1;
  ClipCursor(nil);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
const
  MagicNumber : DWORD = $FFFEFDFC;
var
  FileStream : TFileStream;
  Magic : PDWORD;
  Buffer : PChar;
  BufferLen : PDWORD;
  MD5NewPass,
  MD5VerifyPass : String;
  MD5MD5NewPass : String;
begin
  If FileExists(ChangeFileExt(ParamStr(0),'.bak')) Then
    begin
    DeleteFile(ChangeFileExt(ParamStr(0),'.bak'));
  end;
  FileStream := TFileStream.Create(ParamStr(0),fmOpenRead Or fmShareDenyNone);
  Try
    Magic := AllocMem(4);
    BufferLen := AllocMem(4);
    FileStream.Position := FileStream.Size - 4;
    FileStream.Read(Magic^,4);
    If Magic^ = MagicNumber Then
      begin
      FileStream.Position := FileStream.Size - 8;
      FileStream.Read(BufferLen^,4);
      FileStream.Position := FileStream.Size - 8 - BufferLen^;
      Buffer := AllocMem(BufferLen^);
      FileStream.Read(Buffer^,BufferLen^);
      MD5NewPass := Copy(Buffer,1,StrScan(Buffer,#32) - Buffer);
      Buffer := StrScan(Buffer,#32) + 1;
      MD5MD5NewPass := Buffer;
      If MD5(MD5NewPass) = MD5MD5NewPass Then
        begin
        MD5Password := MD5NewPass;
      end
      Else
        begin
        ShowMessage('Password corrupted! Please reinstall application.'#13#10'Terminating');
        TerminateProcess(GetCurrentProcess,0);
      end;
    end
    Else
      begin
      While True Do
        begin
        PostMessage(Handle,InputBoxMessage,0,0);
        MD5NewPass := MD5(InputBox('New Password Dialog','Please enter your new password:',''));
        PostMessage(Handle,InputBoxMessage,0,0);
        MD5VerifyPass := MD5(InputBox('New Password Dialog','Please re-enter your password for verification:',''));
        If MD5NewPass = MD5VerifyPass Then
          begin
          MD5MD5NewPass := MD5(MD5NewPass);
          FileStream.Free;
          RenameFile(ParamStr(0),ChangeFileExt(ParamStr(0),'.bak'));
          CopyFile(PChar(ChangeFileExt(ParamStr(0),'.bak')),PChar(ParamStr(0)),False);
          FileStream := TFileStream.Create(ParamStr(0),fmOpenReadWrite);
          FileStream.Position := FileStream.Size;
          Buffer := PChar(MD5NewPass + #32 + MD5MD5NewPass);
          BufferLen^ := Length(MD5NewPass + #32 + MD5MD5NewPass);
          FileStream.Write(Buffer^,BufferLen^);
          FileStream.Write(BufferLen^,4);
          CopyMemory(Buffer,@MagicNumber,4);
          FileStream.Write(Buffer^,4);
          FileStream.Free;
          ShowMessage('New password created! Starting application.');
          ShellExecute(0,'open',PChar(ParamStr(0)),'',PChar(ExtractFilePath(ParamStr(0))),SW_SHOWNORMAL);
          TerminateProcess(GetCurrentProcess,0);
          Break;
        end
        Else
          begin
          ShowMessage('Passwords did not match! Please retry.');
        end;
      end;
    end;
  Except
    ShowMessage('Unhandled exception! Please reinstall application.');
    TerminateProcess(GetCurrentProcess,0);
  end;
  FileStream.Free;
  EnableTaskMan(False);
  DoubleBuffered := True;
  fBackground := nil;
  CheckForBackground;
  WindowState := wsMaximized;
  ClientWidth := Screen.Width;
  ClientHeight := Screen.Height;
  Refresh;
  SetForegroundWindow(Handle);
  SetActiveWindow(Application.Handle);
  HookIt;
  RunOnWinStart('Computer Lock',ParamStr(0),True,False);
end;

procedure TfrmMain.FormPaint(Sender: TObject);
var
  CanvasRect : TRect;
begin
  If fBackground <> nil Then
    begin
    CanvasRect.Left := 0;
    CanvasRect.Right := Screen.Width;
    CanvasRect.Top := 0;
    CanvasRect.Bottom := Screen.Height;
    Canvas.StretchDraw(CanvasRect,fBackground.Graphic);
  end;
end;

procedure TfrmMain.FormShow(Sender: TObject);
var
  SystemRect : TRect;
  ClipRect: TRect;
begin
  SystemRect.Left := 0;
  SystemRect.Right := Screen.Width;
  SystemRect.Top := 0;
  SystemRect.Bottom := Screen.Height;
  SetBounds(SystemRect.Left,SystemRect.Top,SystemRect.Right - SystemRect.Left,SystemRect.Bottom - SystemRect.Top);
  ClipRect.Left := -1;
  ClipRect.Top := -1;
  ClipRect.Right := Screen.Width + 1;
  ClipRect.Bottom := Screen.Height + 1;
  ClipCursor(@ClipRect);
  frmLogin.Show;
  frmLogin.Left := (Width div 2) - (frmLogin.Width div 2);
  frmLogin.Top := (Height div 2) - (frmLogin.Height div 2);
end;

end.