{******************************************************************************}
{* Иллюстрация к книге "DirectX. Графика в проектах Delphi".                  *}
{* Издательство BHV. www.bhv.ru                                               *}
{* Краснов М.В. softgl@chat.ru                                                *}
{******************************************************************************}
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  AppEvnts, ExtCtrls,
  DirectDraw, DDUtil, Registry, jpeg;

type
  TfrmDD = class(TForm)
    ApplicationEvents1: TApplicationEvents;
    Timer1: TTimer;
    imgFish1: TImage;
    imgFish2: TImage;
    imgFish3: TImage;
    imgFish4: TImage;
    imgSphere: TImage;
    imgBlue: TImage;
    Timer2: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
    procedure Timer1Timer(Sender: TObject);
    procedure ApplicationEvents1Deactivate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ApplicationEvents1Activate(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
    FDD            : IDirectDraw7;
    FDDSBack       : IDirectDrawSurface7;
    FDDSBackGround : IDirectDrawSurface7;
    FDDSPrimary    : IDirectDrawSurface7;
    FDDSImage      : IDirectDrawSurface7;
    FDDClipper     : IDirectDrawClipper;
    ThisTickCount  : DWORD;
    LastTickCount  : DWORD;
    function UpdateFrame : HRESULT;
    procedure ErrorOut(hRet : HRESULT; FuncName : String);
    function RunScreenSaver : BOOL;
    function BackGround (const X, Y : Integer) : HRESULT;
    function Prepare : HRESULT;
    function RestoreAll : HRESULT;
    function InitDirectDraw (const Wnd : HWND) : HRESULT;
    function CreateFromImage (var FDDS : IDirectDrawSurface7; const Image : TImage; const imgWidth, imgHeight : Integer) : HRESULT;
    function TestPassword : BOOL;
    procedure RunSetPassword;
  public
    { Public declarations }
  end;

type
  TBubble = class
    X, Y : Integer;
    Length : Integer;
    FDDSBubble : IDirectDrawSurface7;
    SpeedBubble : Integer;
    Pict : Array of Array of Word;
    Alpha : Integer;
    procedure Init;
    procedure Render;
  end;

  TFish = class
    XFish, YFish   : Integer;
    Direction      : 0..1;
    WidthFish      : Integer;
    HeightFish     : Integer;
    FDDSFish       : IDirectDrawSurface7;
    SpeedFish      : Integer;
    procedure Init;
    procedure Render;
  end;

const
  ScreenWidth    = 640;
  ScreenHeight   = 480;
  ScreenBitDepth = 16;
  MaxImages      = 20;

var
  frmDD : TfrmDD;
  glX : Integer = 100;
  glY : Integer = 100;
  stX : Integer = 1;
  stY : Integer = 1;
  Bubble : Array [0..MaxImages - 1] of TBubble;
  Fish : Array [0..MaxImages - 1] of TFish;
  NumImages : 1..MaxImages;
  wrkHandle : HWND;
  flgWindowed : BOOL = False;
  FActive : BOOL = False;

implementation

uses frmParams;

{$R *.DFM}

procedure TfrmDD.ErrorOut(hRet : HRESULT; FuncName : String);
var
  t : TextFile;
begin
  AssignFile (t, 'Debug.txt');
  Rewrite (t);
  WriteLn (t, FuncName + ': ' + DDErrorString (hRet));
  CloseFile (t);
  Destroy;
end;

function TfrmDD.CreateFromImage (var FDDS : IDirectDrawSurface7; const Image : TImage; const imgWidth, imgHeight : Integer) : HRESULT;
var
  DC : HDC;
  ddsd : TDDSurfaceDesc2;
  hRet : HResult;
  wrkBitmap1 : TBitMap;
  wrkBitmap2 : TBitMap;
begin
  FDDS := nil;

  ZeroMemory (@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       dwWidth := imgWidth;
       dwHeight := imgHeight;
       ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDS, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create Surface');

  wrkBitmap1 := TBitMap.Create;
  wrkBitmap1.Width := Image.Width;
  wrkBitmap1.Height := Image.Height;

  BitBlt(wrkBitmap1.Canvas.Handle, 0, 0, wrkBitmap1.Width, wrkBitmap1.Height,
         Image.Canvas.Handle, 0, 0, SRCCOPY);

  wrkBitmap2 := TBitMap.Create;
  wrkBitmap2.Width := imgWidth;
  wrkBitmap2.Height := imgHeight;

  wrkBitmap2.Canvas.StretchDraw (Rect (0, 0, imgWidth, imgHeight), wrkBitmap1);

  if FDDS.GetDC(DC) = DD_OK then begin
     BitBlt(DC, 0, 0, imgWidth, imgHeight,
         wrkBitmap2.Canvas.Handle, 0, 0, SRCCOPY);
     FDDS.ReleaseDC(DC);
  end;

  wrkBitmap1.Free;
  wrkBitmap2.Free;

  Result := DDSetColorKey (FDDS, Image.Canvas.Pixels [0, 0]);
end;

procedure TFish.Init;
procedure Rotate;
var
  desc : TDDSURFACEDESC2;
  i, j : Integer;
  wrkW : Word;
begin
  ZeroMemory (@desc, SizeOf(desc));
  desc.dwSize := SizeOf(desc);

  if Failed (FDDSFish.Lock (nil, desc, DDLOCK_WAIT, 0)) then Exit;

  for i := 0 to (WidthFish - 1) div 2 do
    for j := 0 to HeightFish - 1 do begin
      wrkW := PWord (Integer (desc.lpSurface) +
                            j * desc.lPitch + i * 2)^;
      PWord (Integer (desc.lpSurface) +
             j * desc.lPitch + i * 2)^ :=
      PWord (Integer (desc.lpSurface) +
             j * desc.lPitch + (WidthFish - 1 - i) * 2)^;
      PWord (Integer (desc.lpSurface) +
             j * desc.lPitch + (WidthFish - 1 - i) * 2)^ := wrkW;
  end;

  FDDSFish.Unlock (nil);
end;
begin
  case random (4) of
    0 : begin
        WidthFish := random (141) + 24;
        HeightFish := WidthFish * 129 div 164;
        if Failed (frmDD.CreateFromImage (FDDSFish, frmDD.imgFish1, WidthFish, HeightFish))
           then frmDD.ErrorOut(DD_FALSE, 'CreateFish');
        end;
    1 : begin
        WidthFish := random (161) + 22;
        HeightFish := WidthFish * 115 div 182;

        if Failed (frmDD.CreateFromImage (FDDSFish, frmDD.imgFish2, WidthFish, HeightFish))
           then frmDD.ErrorOut(DD_FALSE, 'CreateFish');
        end;
    2 : begin
        WidthFish := random (161) + 22;
        HeightFish := WidthFish * 122 div 182;

        if Failed (frmDD.CreateFromImage (FDDSFish, frmDD.imgFish3, WidthFish, HeightFish))
           then frmDD.ErrorOut(DD_FALSE, 'CreateFish');
        end;
    3 : begin
        WidthFish := random (175) + 22;
        HeightFish := WidthFish * 142 div 182;

        if Failed (frmDD.CreateFromImage (FDDSFish, frmDD.imgFish4, WidthFish, HeightFish))
           then frmDD.ErrorOut(DD_FALSE, 'CreateFish');
        end;
  end;

  Direction := random (2);
  SpeedFish := random (6) + 1;

  if Direction = 0
     then XFish := -WidthFish
     else begin
     XFish := ScreenWidth;
     Rotate;
  end;

  YFish := random (360) + 5;
end;

procedure TFish.Render;
var
  wrkRect : TRect;
begin
  case Direction of
    0 : begin
        XFish := XFish + SpeedFish;
        if XFish > ScreenWidth then Init;
        end;
    1 : begin
        XFish := XFish - SpeedFish;
        if XFish < -WidthFish then Init;
        end;
  end;

  if XFish <= 0 then begin
  SetRect (wrkRect, -XFish, 0, WidthFish, HeightFish);
  frmDD.FDDSBack.BltFast (0, YFish, FDDSFish,
             @wrkRect, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  end
  else begin
  if XFish <= ScreenWidth - WidthFish then begin
  frmDD.FDDSBack.BltFast (XFish, YFish, FDDSFish,
             nil, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  end
  else begin
  SetRect (wrkRect, 0, 0, ScreenWidth - XFish, HeightFish);
  frmDD.FDDSBack.BltFast (XFish, YFish, FDDSFish,
             @wrkRect, DDBLTFAST_WAIT or DDBLTFAST_SRCCOLORKEY);
  end;
  end;
end;

procedure TBubble.Init;
var
  desc : TDDSURFACEDESC2;
  i, j : Integer;
begin
  Length := random (30) + 20;

  if Failed (frmDD.CreateFromImage (FDDSBubble, frmDD.imgSphere, Length, Length))
             then frmDD.ErrorOut(DD_FALSE, 'Create Bubble');

  SetLength(Pict, Length);

  for i := 0 to Length - 1 do
      SetLength(Pict [i], Length);

  ZeroMemory (@desc, SizeOf(desc));
  desc.dwSize := SizeOf(desc);

  if Failed (FDDSBubble.Lock (nil, desc, DDLOCK_WAIT, 0)) then Exit;

  for i := 0 to Length - 1 do
  for j := 0 to Length - 1 do
      Pict [i, j] := PWord (Integer (desc.lpSurface) +
                            j * desc.lPitch + i * 2)^;

  FDDSBubble.Unlock (nil);

  FDDSBubble := nil;

  Alpha := random (150) + 50;

  SpeedBubble := random (3) + 1;

  X := random (550) + Length;
  Y := ScreenHeight - Length;
end;

procedure TBubble.Render;
function Blend (const X, Y : Integer) : HRESULT;
var
  desc : TDDSURFACEDESC2;
  i, j : Integer;
  wrkPointer : PWORD;
  sTemp, dTemp : WORD;
  sb, db, sg, dg, sr, dr : Byte;
  Blue, Green, Red : Byte;
  hRet : HRESULT;
begin
  ZeroMemory (@desc, SizeOf(desc));
  desc.dwSize := SizeOf(desc);

  hRet := frmDD.FDDSBack.Lock (nil, desc, DDLOCK_WAIT, 0);
  if Failed (hRet) then begin
     Result := hRet;
     Exit;
  end;

  for i := 0 to Length - 1 do
      for j := 0 to Length - 1 do
       if Pict [i, j] <> 0 then begin
       wrkPointer := PWord (Integer(desc.lpSurface) + (Y + j) * desc.lPitch +
                     (X + i) * 2);
       sTemp := Pict [i, j];
       dTemp := wrkPointer^;

       sb := sTemp and $1F;
       db := dTemp and $1F;
       sg := (sTemp shr 5)  and $3F;
       dg := (dTemp shr 5)  and $3F;
       sr := (sTemp shr 11) and $1F;
       dr := (dTemp shr 11) and $1F;
       Blue  := (Alpha * (sb - db) shr 8) + db;
       Green := (Alpha * (sg - dg) shr 8) + dg;
       Red   := (Alpha * (sr - dr) shr 8) + dr;
       wrkPointer^ := Blue or (Green shl 5) or (Red shl 11);
  end;

  Result := frmDD.FDDSBack.Unlock (nil);
end;
begin
  Y := Y - SpeedBubble;
  if Y < 0 then Init;
  Blend (X, Y);
end;

procedure TfrmDD.FormCreate(Sender: TObject);
var
  hRet : HRESULT;
  i : Integer;
begin
  if not RunScreenSaver then begin
     Free;
     Exit;
  end;

  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, nil, 0);

  FDDClipper := nil;
  FDDSImage := nil;
  FDDSBack := nil;
  FDDSPrimary := nil;
  FDDSBackGround := nil;
  FDD := nil;

  hRet := DirectDrawCreateEx (nil, FDD, IDirectDraw7, nil);
  if Failed(hRet) then ErrorOut(hRet, 'DirectDrawCreateEx');

  InitDirectDraw (wrkHandle);

  Randomize;

  for i := 0 to NumImages - 1 do begin
    Bubble [i] := TBubble.Create;
    Bubble [i].Init;
    Fish [i] := TFish.Create;
    Fish [i].Init;
  end;

  if not flgWindowed then ShowCursor (False);
end;

procedure TfrmDD.FormDestroy(Sender: TObject);
var
  i : Integer;
begin
  if Assigned(FDD) then begin
      for i := NumImages - 1 downto 0 do begin
          if Assigned(Fish [i].FDDSFish) then begin
             Fish [i].FDDSFish._Release;
             Fish [i].FDDSFish := nil;
          end;
          if Assigned(Bubble [i].FDDSBubble) then begin
             Bubble [i].FDDSBubble._Release;
             Bubble [i].FDDSBubble := nil;
          end;
      end;
      if Assigned(FDDSImage) then begin
         FDDSImage._Release;
         FDDSImage := nil;
      end;
      if Assigned(FDDSBackGround) then begin
         FDDSBackGround._Release;
         FDDSBackGround := nil;
      end;
      if flgWindowed then
         if Assigned(FDDSBack) then begin
            FDDSBack._Release;
            FDDSBack := nil;
      end;
      if Assigned(FDDSPrimary) then begin
         FDDSPrimary._Release;
         FDDSPrimary := nil;
      end;
      FDD := nil;
  end;
  for i := NumImages - 1 downto 0 do begin
      if Assigned (Fish [i]) then Fish [i].Free;
      if Assigned (Bubble [i]) then Bubble [i].Free;
  end;
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, nil, 0);
end;

var
  mouseX, mouseY : Integer;
  First : BOOL = True;

procedure TfrmDD.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  FDD.FlipToGDISurface;
  if TestPassword then begin
     SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, nil, 0);
     Close;
  end;   
end;

procedure TfrmDD.ApplicationEvents1Idle(Sender: TObject;
  var Done: Boolean);
begin
  if FActive then
  if Failed (UpdateFrame) then Timer2.Enabled := True;
  Done := False;
end;

function TfrmDD.UpdateFrame : HRESULT;
var
  i : Integer;
  rcDest, destRect : TRECT;
  p : TPOINT;
  hRet : HRESULT;
begin
  ThisTickCount := GetTickCount;

  if ThisTickCount - LastTickCount > 10 then begin
     hRet := BackGround (glX, glY);
     if Failed (hRet) then begin
        Result := hRet;
        Exit
     end;
     glX := glX + stX;
     if glX >= 200
        then glX := glX - 200
        else if glX < 0 then glX := glX + 200;
     glY := glY + stY;
     if glY >= 200
        then glY := glY - 200
        else if glY < 0 then glY := glY + 200;
     for i := 0 to NumImages - 1 do begin
       Bubble [i].Render;
       Fish [i].Render;
     end;

     if not flgWindowed then begin
        hRet := FDDSPrimary.Flip(nil, DDFLIP_WAIT);
        if Failed (hRet) then begin
           Result := hRet;
           Exit
        end;
        end
        else begin
        p.X := 0;
        p.Y := 0;
        Windows.ClientToScreen(wrkHandle, p);
        Windows.GetClientRect(wrkHandle, rcDest);
        OffsetRect(rcDest, p.X, p.Y);
        SetRect (destRect, 0, 0, ScreenWidth, ScreenHeight);
        hRet := FDDSPrimary.Blt (@rcDest, FDDSBack, @destRect, DDBLT_WAIT, nil);
        if Failed (hRet) then begin
           Result := hRet;
           Exit
        end;
     end;

     LastTickCount := GetTickCount;
  end;

  Result := DD_OK;
end;

function TfrmDD.BackGround (const X, Y : Integer) : HRESULT;
var
  rcRect : TRECT;
begin
  SetRect (rcRect, X, Y, X + ScreenWidth, Y + ScreenHeight);

  Result := FDDSBack.BltFast (0, 0, FDDSBackGround, @rcRect, DDBLTFAST_WAIT);
end;

function TfrmDD.Prepare : HRESULT;
var
  i, j : Integer;
  hRet : HRESULT;
begin
  for i := 0 to 4 do
      for j := 0 to 3 do begin
      hRet := FDDSBackGround.BltFast (i * 200, j * 200, FDDSImage,
                                      nil, DDBLTFAST_WAIT);
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;
  end;

  Result := DD_OK;
end;

procedure TfrmDD.Timer1Timer(Sender: TObject);
begin
  stX := 2 - random (4);
  stY := 2 - random (4);
end;

function TfrmDD.InitDirectDraw (const Wnd : HWND) : HRESULT;
var
  hRet : HRESULT;
  ddsd : TDDSurfaceDesc2;
  ddscaps : TDDSCaps2;
  Rgn : THandle;
begin
  if not flgWindowed then begin
     BorderStyle := bsNone;
     hRet := FDD.SetCooperativeLevel(Handle, DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
     if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

     hRet := FDD.SetDisplayMode (ScreenWidth, ScreenHeight, ScreenBitDepth, 0, 0);
     if Failed(hRet) then ErrorOut(hRet, 'SetDisplayMode');

     ZeroMemory(@ddsd, SizeOf(ddsd));
     with ddsd do begin
          dwSize := SizeOf(ddsd);
          dwFlags := DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
          ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX;
          dwBackBufferCount := 1;
     end;
     hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
     if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

     ZeroMemory(@ddscaps, SizeOf(ddscaps));
     ddscaps.dwCaps := DDSCAPS_BACKBUFFER;
     hRet := FDDSPrimary.GetAttachedSurface(ddscaps, FDDSBack);
     if Failed(hRet) then ErrorOut(hRet, 'GetAttachedSurface');
  end
  else begin
     Rgn := CreateRectRgn (0, 0, 0, 0);
     SetWindowRgn(Handle, Rgn, True);
     ShowWindow(Application.Handle, SW_HIDE);
     hRet := FDD.SetCooperativeLevel(Wnd, DDSCL_NORMAL);
     if Failed(hRet) then ErrorOut(hRet, 'SetCooperativeLevel');

     ZeroMemory(@ddsd, SizeOf(ddsd));
     with ddsd do begin
          dwSize := SizeOf(ddsd);
          dwFlags := DDSD_CAPS;
          ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
     end;
     hRet := FDD.CreateSurface(ddsd, FDDSPrimary, nil);
     if Failed(hRet) then ErrorOut(hRet, 'Create Primary Surface');

     ZeroMemory(@ddsd, SizeOf(ddsd));
     with ddsd do begin
          dwSize := SizeOf(ddsd);
          dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
          ddsCaps.dwCaps :=  DDSCAPS_OFFSCREENPLAIN;
          dwWidth := ScreenWidth;
          dwHeight := ScreenHeight;
     end;

     hRet := FDD.CreateSurface(ddsd, FDDSBack, nil);
     if Failed(hRet) then ErrorOut(hRet, 'Create Back Surface');
     hRet := FDD.CreateClipper(0, FDDClipper, nil);
     if Failed(hRet) then ErrorOut(hRet, 'CreateClipper FAILED');

     FDDClipper.SetHWnd(0, Wnd);
     FDDSPrimary.SetClipper(FDDClipper);
     FDDClipper := nil;
  end;

  ZeroMemory(@ddsd, SizeOf(ddsd));
  with ddsd do begin
       dwSize := SizeOf(ddsd);
       dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH;
       ddsCaps.dwCaps :=  DDSCAPS_OFFSCREENPLAIN;
       dwWidth := 1000;
       dwHeight := 800;
  end;
  hRet := FDD.CreateSurface(ddsd, FDDSBackGround, nil);
  if Failed(hRet) then ErrorOut(hRet, 'Create BackGround Surface');

  if Failed (frmDD.CreateFromImage (FDDSImage, imgBlue, 200, 200))
             then frmDD.ErrorOut(DD_FALSE, 'CreateFish');

  if Failed (Prepare) then ErrorOut(DD_FALSE, 'Prepare');

  Result := DD_OK;
end;

function TfrmDD.RunScreenSaver : BOOL;
const
  SECTION = 'Fish';
var
  S : string;
  FIniFile: TRegIniFile;
begin
  Result := False;
  FIniFile := TRegIniFile.Create;
  NumImages := FIniFile.ReadInteger(SECTION, 'NumImages', MaxImages);

  S := ParamStr(1);
  if Length(S) > 1 then begin
     Delete(S, 1, 1);
     S[1] := UpCase(S[1]);
     if S = 'P' then begin
        flgWindowed := True;
        wrkHandle := StrToInt(ParamStr(2));
     end else
     if S[1] = 'C' then begin
      with TfrmPar.Create (nil) do begin
        tbFish.Max := MaxImages;
        tbFish.Position := NumImages;
        ShowModal;
        NumImages := tbFish.Position;
        Free;
     end;
     FIniFile.WriteInteger (SECTION, 'NumImages', NumImages);
     FIniFile.Free;
     Exit;
     end else
     if S[1] = 'A' then begin
        RunSetPassword;
        Exit;
     end;
  end;

  if Assigned (FIniFile) then FIniFile.Free;

  Result := True;
end;

function TfrmDD.RestoreAll : HRESULT;
var
  i : Integer;
  hRet : HRESULT;
begin
  hRet := FDDSPrimary._Restore;
  if Succeeded (hRet) then begin
      if flgWindowed then begin
         hRet := FDDSBack._Restore;
         if Failed (hRet) then begin
            Result := hRet;
            Exit;
         end;
      end;

      hRet := FDDSBackGround._Restore;
      if Failed (hRet) then begin
         Result := hRet;
         Exit;
      end;

      for i := 0 to NumImages - 1 do begin
          Bubble [i] := TBubble.Create;
          Bubble [i].Init;
          Fish [i] := TFish.Create;
          Fish [i].Init;
      end;

      Result := DD_OK
  end else Result := hRet;
end;

procedure TfrmDD.ApplicationEvents1Deactivate(Sender: TObject);
begin
  Close
end;

procedure TfrmDD.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hide
end;

procedure TfrmDD.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  Key : Word;
begin
  if first then begin
     mouseX := X;
     mouseY := Y;
     first := False;
     end
     else if (mouseX <> X) and (mouseY <> Y) then
     FormKeyDown(nil, Key, []);
end;

procedure TfrmDD.ApplicationEvents1Activate(Sender: TObject);
begin
  Factive := True;
end;

function TfrmDD.TestPassword : BOOL;
type
  TVSSPFunc = function(Parent : hWnd) : BOOL; stdcall;
var
  Key   : hKey;
  D1,D2 : Integer;
  Value : Integer;
  Lib   : THandle;
  VSSPFunc : TVSSPFunc;
begin
  Result := True;
  if RegOpenKeyEx(hKey_Current_User,'Control Panel\Desktop', 0,
      Key_Read, Key) = Error_Success then begin
      D2 := SizeOf(Value);
      if RegQueryValueEx(Key, 'ScreenSaveUsePassword', nil, @D1,
        @Value,@D2) = Error_Success then begin
        if Value <> 0 then begin
           Lib := LoadLibrary('PASSWORD.CPL');
           if Lib > 32 then begin
              @VSSPFunc := GetProcAddress(Lib, 'VerifyScreenSavePwd');
              ShowCursor(True);
              if @VSSPFunc <> nil then Result := VSSPFunc(Handle);
              ShowCursor(False);
              FreeLibrary(Lib);
           end;
         end;
       end;
      RegCloseKey(Key);
  end;
end;

procedure TfrmDD.RunSetPassword;
type
  TPCPAFunc = function(A : PChar; Parent : hWnd; B, C : Integer) : Integer; stdcall;
var
  Lib : THandle;
  PCPAFunc : TPCPAFunc;
begin
  Lib := LoadLibrary('MPR.DLL');
  if Lib > 32 then begin
    @PCPAFunc := GetProcAddress(Lib, 'PwdChangePasswordA');
    if @PCPAFunc <> nil then PCPAFunc('SCRSAVE', StrToInt(ParamStr(2)), 0, 0);
    FreeLibrary(Lib);
  end;
end;

procedure TfrmDD.Timer2Timer(Sender: TObject);
begin
  if Succeeded (RestoreAll) then Timer2.Enabled := False;
end;

procedure TfrmDD.FormActivate(Sender: TObject);
begin
  LastTickCount := GetTickCount;
end;

end.

