screensaver.pas

一个用Delphi编写的很好的屏保程序

unit ScreenSaver;
interface
uses
  Messages,
  Windows;

{parts of this code based on ScrnSave.Cxx which is supplied with the SDK
Samples\Opengl\scrsave\common. I did translate the whole unit, but it was such
a mess I couldn't bring myself to use it (mgl)

This unit could be used to implement any screensaver - not just OpenGL.
}

type
  TSSMode = (ssSetPwd, ssPreview, ssConfig, ssRun);
  TInitCallback = procedure (Window: hWnd; Mode: TSSMode);
  TWndCallback = procedure(Window: hWnd);


function DoScreenSaver(
    InitProc: TInitCallback;
    RunProc,
    DoneProc,
    ConfigProc: TWndCallback;
    RunPeriod: Integer): TSSMode;


{
InitProc is called when the screensaver window has
been created (WM_CREATE) (preview and run only)

RunProc is called periodically during the life of the window in Preview and Run modes.
Use this to animate the display. (preview and run only)

DoneProc is called when the window is destroyed (WM_DESTROY). (preview and run only)

ConfigProc is called to configure the screensaver. Should throw a modal dialog to
edit registry data as necessary. (config mode only)

Communication of settings between ConfigMode and run mode must be done via the
registry (or dedicated disk file)
}


implementation
uses
  SysUtils;

{$I ScreenSaver.inc}

const
  Threshold = 5; //pixels
  TimerID = 1;

var
  SSMode: TSSMode;
  MousePt: TPoint;
  InitP: TInitCallback;
  RunP: TWndCallback;
  DoneP: TWndCallback;
  TimerRunning: Boolean;
  TimerPeriod: Integer;
  PasswordCheckFunc: function (Wnd: HWND): BOOL; stdcall;
  PasswordDLL: hModule;
  CheckingPW: Boolean;

procedure StartTimer(Wnd: hWnd);
begin
  TimerRunning:= Assigned(RunP) and (TimerPeriod > 0) and
     (SetTimer(Wnd, TimerID, TimerPeriod, nil) <> 0);
end;

procedure StopTimer(Wnd: hWnd);
var
  Msg: TMsg;
begin
  if TimerRunning then
  begin
    KillTimer(Wnd, TimerID);
    {flush any WM_TIMER messages, in the unlikely event that any are hanging about}
    repeat until not PeekMessage( Msg, Wnd, WM_TIMER, WM_TIMER, PM_REMOVE);
    TimerRunning:= false
  end;
end;

function DoPasswordCheck( Wnd: HWND ): BOOL;
begin
  if Assigned(PasswordCheckFunc) then
  begin
    CheckingPW:= True;
{I am not entirely sure that this is correct. There is sometimes a problem
with the pw dlg appearing behind the ss wnd. I have not been able to positively
prove a correlation between the problem and this "fix". Does not seem to be
a problem on win95 but is on Vanessa's 500MHz Win98 machine}
{$IFDEF Debug}
    Result:= PasswordCheckFunc(Wnd);
{$ELSE}
    SetWindowPos(Wnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
    Result:= PasswordCheckFunc(Wnd);
    SetWindowPos(Wnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
{$ENDIF}
    CheckingPW:= false
  end else
  begin
    Result:= true
  end
end;


function WndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD; stdcall;
var
  Pt: TPoint;
begin
  Result:= 1;
  if not CheckingPW then
  begin
    case Msg of
      WM_CREATE:
      begin
        Result:= 0;
        if Assigned(InitP) then
          InitP(Wnd, SSMode);
      end;

      WM_DESTROY:
      begin
        Result:= 0;
        StopTimer(Wnd);
        if Assigned(DoneP) then
           DoneP(Wnd);
        PostQuitMessage(0)
      end;

      WM_TIMER:
      begin
        if (wParam = TimerID) and
           Assigned(RunP) then
        begin
          Result:= 0;
          RunP(Wnd)
        end
      end;
    end;

    if (SSMode = ssRun) then
    case Msg of

      WM_SHOWWINDOW:
      begin
        if BOOL(wParam) then
          SetCursor(0)
      end;

      WM_CLOSE:
      begin
        if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
            not DoPasswordCheck(Wnd) then
        begin
          GetCursorPos(MousePt);  // re-establish
          Result:= 0
        end
      end;

      WM_SYSCOMMAND:
      begin
        if (wParam = SC_SCREENSAVE) or (wParam=SC_CLOSE) then
          Result:= 0
      end;

      WM_SETCURSOR:
      begin
        Result:= 0;
        SetCursor(0)
      end;

  {$IFNDEF Debug}
      WM_NCACTIVATE:
      begin
        if wParam = 0 then
          Result:= 0
      end;
  {$ENDIF}

      WM_ACTIVATE:
      begin
        if wParam <> 0 then
        begin
          Result:= 0;
          GetCursorPos(MousePt)
        end;
      end;

  {$IFNDEF Debug}
      WM_MOUSEMOVE:
      begin
        GetCursorPos(Pt);
        if (abs(MousePt.X - Pt.X) > Threshold) or
           (abs(MousePt.Y - Pt.Y) > Threshold) then
        begin
          Result:= 0;
          PostMessage (Wnd, WM_CLOSE, 0, 0)
        end
      end;
  {$ENDIF}

      WM_LBUTTONDOWN, WM_MBUTTONDOWN,
      WM_RBUTTONDOWN, WM_KEYDOWN, WM_SYSKEYDOWN:
      begin
        Result:= 0;
        PostMessage (Wnd, WM_CLOSE, 0, 0)
      end;
    end;
  end;
  if Result = 1 then
    Result:= DefWindowProc (Wnd, msg, wParam, lParam)
end;




function DoScreenSaver( InitProc: TInitCallback;
                        RunProc, DoneProc, ConfigProc: TWndCallback;
                        RunPeriod: Integer): TSSMode;


procedure SaverRunning( value: BOOL);
//not needed under NT stops ctrl-alt-del etc to circumvent password
var
  dummy: UINT;
begin
  SystemParametersInfo( SPI_SCREENSAVERRUNNING, DWORD(value), @dummy, 0 )
end;

procedure UnloadPwdDLL;
begin
  if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (PasswordDLL <> 0) then
  begin
    FreeLibrary(PasswordDLL);
    PasswordDLL:= 0;
    PasswordCheckFunc:= nil;
    SaverRunning(false)
  end;
end;

procedure LoadPwdDLL;
const
  ScreenSaverKey = 'Control Panel\Desktop';
  PasswordActiveValue = 'ScreenSaveUsePassword';
  PwdDLL = 'PASSWORD.CPL';
  PwdFnName = 'VerifyScreenSavePwd';
var
  Key: HKEY;
  Val, Size: DWORD;
begin
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
  begin
    if PasswordDLL <> 0 then
      UnloadPwdDLL;
    { look in registry to see if password turned on, otherwise don't bother to
      load password handler DLL }
    if RegOpenKey(HKEY_CURRENT_USER, ScreenSaverKey,  Key) = ERROR_SUCCESS then
    begin
      Size:= sizeof(Val);
      if (RegQueryValueEx(Key, PasswordActiveValue, nil, nil, @Val, @Size) = ERROR_SUCCESS) and
         (Val <> 0) then
      begin
        // try to load the DLL that contains password proc.
        PasswordDLL:= LoadLibrary(PwdDLL);
        if PasswordDLL <> 0 then
        begin
          PasswordCheckFunc:= GetProcAddress(PasswordDLL, PwdFnName);
          if Assigned(PasswordCheckFunc) then
            SaverRunning(True)
          else
            UnloadPwdDLL;
        end;
      end;
      RegCloseKey(Key)
    end
  end
end;


function CreateMainWindow(hParent: HWND): HWnd;
var
  nCx, nCy: Integer;
  WndClass: TWndClass;
  rcParent: TRect;
  uStyle, uExStyle: DWORD;
  hOther: hWnd;
  pszWindowTitle: String;

const
  pszWindowClass = 'WindowsScreenSaverClass';

begin
  FillChar(WndClass, SizeOf(WndClass), 0);
  with WndClass do
  begin
    hCursor        := 0;
    hIcon          := LoadIcon( System.MainInstance, MAKEINTATOM( IDI_APP ) );
    lpszMenuName   := nil;
    lpszClassName  := pszWindowClass;
    hbrBackground  := GetStockObject( BLACK_BRUSH );
    hInstance      := System.MainInstance;
    style          := CS_VREDRAW or CS_HREDRAW or CS_DBLCLKS or CS_OWNDC;
    lpfnWndProc    := @WndProc;
    cbWndExtra     := 0;
    cbClsExtra     := 0
  end;
  if hParent <> 0 then
  begin
    GetClientRect( hParent, rcParent );
    nCx:= rcParent.right;
    nCy:= rcParent.bottom;
    uStyle:= WS_CHILD or WS_VISIBLE or WS_CLIPCHILDREN;
    uExStyle:= 0;
    pszWindowTitle:= 'Preview'
  end else
  begin
    nCx:= GetSystemMetrics( SM_CXSCREEN );
    nCy:= GetSystemMetrics( SM_CYSCREEN );
    uStyle:= WS_POPUP or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
  {$IFDEF Debug}
    uExStyle:= 0;
  {$ELSE}
    uExStyle:= WS_EX_TOPMOST;
  {$ENDIF}
    pszWindowTitle:= 'Screen Saver';
    hOther:= FindWindow( pszWindowClass, PChar(pszWindowTitle) );
    if (hOther <> 0) and IsWindow( hOther ) then
    begin
      SetForegroundWindow( hOther );
      Result:= 0;
      Exit
    end
  end;
  if Windows.RegisterClass( WndClass ) <> 0 then
    Result:= CreateWindowEx( uExStyle, PChar(pszWindowClass), PChar(pszWindowTitle),
                        uStyle, 0, 0, nCx, nCy, hParent, 0,
                        System.MainInstance, nil )
  else
    Result:= 0
end;

function TestArg1(C: Char): Boolean;
var
  S: String;
begin
  S:= UpperCase(ParamStr(1));
  case Length(S) of
    0: Result:= true;
    1: Result:= S[1] = C;
  else
    Result:= (S[1] in ['-','/','\']) and
             (S[2] = C)
  end;
end;

var
  Wnd         : HWnd;
  SysDir      : String;
  NewLen      : Integer;
  Dll         : hModule;
  PwdFunc: function(a: LPCTSTR; b: HWND; c: DWORD; d: Pointer): DWORD; stdcall;
  Msg: TMsg;

begin
  if TestArg1('C') then
    SSMode:= ssConfig
  else
  if TestArg1('A') then
    SSMode:= ssSetPwd
  else
  if TestArg1('P') then
    SSMode:= ssPreview
  else
    SSMode:= ssRun;
  Result:= SSMode;

  if (SSMode = ssSetPwd) and (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then
  begin  {not appropriate in WindowsNT}
    SetLength(SysDir,MAX_PATH);
    NewLen := GetSystemDirectory(PChar(SysDir),MAX_PATH);
    SetLength(SysDir,NewLen);
    if (Length(SysDir) > 0) and (SysDir[Length(SysDir)] <> '\') then
      SysDir := SysDir+'\';
    Dll := LoadLibrary(PChar(SysDir+'MPR.DLL'));
    if Dll <> 0 then
    begin
      PwdFunc := GetProcAddress(Dll,'PwdChangePasswordA');
      if Assigned(PwdFunc) then
        PwdFunc('SCRSAVE',StrToInt(ParamStr(2)),0,nil);
      FreeLibrary(Dll);
    end;
  end else
  if SSMode = ssConfig then
  begin
    if Assigned(ConfigProc) then
      ConfigProc(GetForegroundWindow)
  end else
  begin  {preview or run}
    RunP:= RunProc;
    InitP:= InitProc;
    DoneP:= DoneProc;
    TimerPeriod:= RunPeriod;
    LoadPwdDLL;
    try
      if SSMode = ssPreview then
        Wnd:= StrToInt(ParamStr(2))
      else
        Wnd:= 0;
      Wnd:= CreateMainWindow(Wnd);
      if Wnd <> 0 then
      begin
        StartTimer(Wnd);
        if  SSMode <> ssPreview  then
          SetForegroundWindow( Wnd );
        while GetMessage( msg, 0, 0, 0 ) do
        begin
          TranslateMessage( msg );
          DispatchMessage( msg )
        end
      end
    finally
      UnloadPwdDLL
    end
  end
end;

end.