mmscrsv.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 12.08.98 - 13:15:42 $                                        =}
{========================================================================}
unit MMScrsv;

{$I COMPILER.INC}

{.$DEFINE _MMDEBUG}

interface

uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinProcs,
  WinTypes,
{$ENDIF}
  SysUtils,
  Messages,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  IniFiles,
  ExtCtrls,
  registry,
  MMObj
  {$IFDEF _MMDEBUG}
  ,MMDebug
  {$ENDIF}
  ;

type
  TPWCheckEvent = procedure(Sender: TObject; var CanClose: Boolean) of Object;
  TMMScreenSaverKind = (skFullScreen,skChildPreview,skNormalWindow,skConfigDialog,skSetPassword);

  EMMScreenSaver = class(Exception);

  {-- TMMScreenSaver ----------------------------------------------------}
  TMMScreenSaver = class(TMMComponent)
  private
    FBitmap:TBitmap;
    FColor:TColor;
    FSaveBack:Boolean;
    FPosition, FOldPos:TPoint;
    FTitle:String;
    FIniFile:TRegIniFile;
    FSection:String;
    FOnSetupDlg:TNotifyEvent;
    FOnSaverStart:TNotifyEvent;
    FOnSaverEnd:TNotifyEvent;
    FOnPasswordSuspend:TNotifyEvent;
    FOnPasswordResume:TNotifyEvent;
    FFlag:Boolean;
    FSave:Integer;
    FSavePos:TPoint;
    FSaverActive:Boolean;
    FHided:Boolean;
    FOwnerProc:Pointer;
    FOldProc:TFarProc;
    FPreviewScale:Boolean;
    FActivated:Boolean;
    FInClose:Boolean;
    FClosing:Boolean;

    function  GetPreviewMode: Boolean;
    function  GetFormParent: THandle;
    function  GetKind: TMMScreenSaverKind;
    Procedure SetTitle(aValue:String);
    function  GetSection:String;
    procedure SaverClose;
    procedure Apptest(var Msg: TMsg; var Handled: Boolean);
  protected
    procedure Loaded; override;
    procedure HideCursor;
    procedure ShowCursor;
    procedure CreateWrapper;
    procedure DestroyWrapper;
    procedure OwnerProc(var Msg: TMessage);
  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;

    procedure ResizeOwner;
    procedure CreateParams(var Params: TCreateParams);
    property Kind: TMMScreenSaverKind read GetKind;
    property PreviewMode: Boolean read GetPreviewMode;
    property Bitmap:TBitmap read FBitmap;
    property FormParent: THandle read GetFormParent;
    property Inifile:TRegInifile read FIniFile;
    property Section:String read GetSection;
  published
    property OnSetupDlg: TNotifyEvent read FOnSetupDlg write FOnSetupDlg;
    property OnSaverStart: TNotifyEvent read FOnSaverStart write FOnSaverStart;
    property OnSaverEnd: TNotifyEvent read FOnSaverEnd write FOnSaverEnd;

    Property Color: TColor read FColor write FColor default clBlack;
    Property SaveBackground:Boolean read FSaveBack write FSaveBack default false;
    Property Title:String read FTitle write SetTitle;
    property PreviewScale: Boolean read FPreviewScale write FPreviewScale default True;
    property OnPasswordSuspend: TNotifyEvent read FOnPasswordSuspend write FOnPasswordSuspend;
    property OnPasswordResume: TNotifyEvent read FOnPasswordResume write FOnPasswordResume;
  end;

implementation

uses
    Consts,
    MMUtils;

var
    Kind        : TMMScreenSaverKind;
    ChildParent : THandle = 0;

{------------------------------------------------------------------------}
procedure ForceAppQuit;
begin
    Application.Terminate;
    Halt;
end;

{------------------------------------------------------------------------}
function GetParamHandle: THandle;
begin
    if ParamCount < 2 then ForceAppQuit;
    Result := 0;
    try
        Result := StrToInt(ParamStr(2));
    except
        ForceAppQuit;
    end;
end;

{------------------------------------------------------------------------}
procedure GetSaverParams;
var
    Key: string;
begin
    Kind := skNormalWindow;

    Key := UpperCase(Copy(ParamStr(1),1,2));
    if (Length(Key) >= 2) and (Key[1] = '/') then
        case Key[2] of
            'C': Kind := skConfigDialog;
            'S': Kind := skFullScreen;
            'W': Kind := skNormalWindow;
            'P': Kind := skChildPreview;
            'A': Kind := skSetPassword;
        end;

    if (Kind = skChildPreview) or (Kind = skSetPassword) then
        ChildParent := GetParamHandle;
end;

{== TMMScreenSaver ======================================================}
constructor TMMScreenSaver.Create(aOwner:TComponent);
begin
  inherited Create(aOwner);

  FPreviewScale := True;
  FBitmap := TBitmap.Create;
  FColor := clblack;
  FIniFile := TRegIniFile.Create('Control Panel\Desktop');
  FFlag := False;
end;

{-- TMMScreenSaver ------------------------------------------------------}
destructor TMMScreenSaver.Destroy;
var
   Dummy: Integer;
begin
   if not (csDesigning in ComponentState) then
   begin
       if PreviewMode then
          DestroyWrapper;
       ShowCursor;
       if FSaverActive then
       begin
          SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,Word(False),@Dummy,0);
          SystemParametersInfo(SPI_SCREENSAVERRUNNING,Word(False),@Dummy,0);
          SystemParametersInfo(SPI_SETFASTTASKSWITCH,Word(True),@Dummy,0);
       end;
   end;

   FIniFile.Free;
   FBitmap.Free;

   inherited Destroy;
end;

{-- TMMScreenSaver ------------------------------------------------------}
procedure TMMScreenSaver.Loaded;
var
   FCanvas      : TCanvas;
   DC           : HDC;
   Dummy        : Integer;
begin
   inherited Loaded;

   Application.Title := 'SCRNSAVE:'+FTitle;
   SetString(FSection,PChar(Application.Title),Length(Application.Title));

   if not (csDesigning in ComponentState) then
   begin
      case Kind of
            skConfigDialog:
                begin
                    TForm(Owner).Enabled := False;
                    if Assigned(FOnSetupDlg) then
                       FOnSetupDlg(Application);
                    ForceAppQuit;
                end;
            skFullScreen, skNormalWindow:
                begin
                    if FSaveBack then
                    begin
                        FCanvas := TCanvas.Create;
                        try
                            DC := GetDC(0);
                            try
                                FCanvas.Handle := DC;
                                with FBitmap do
                                begin
                                    Width := Screen.Width;
                                    Height:= Screen.Height;
                                    Canvas.Copyrect(Rect(0,0,Width,Height), FCanvas, Rect(0,0,Width,Height));
                                end;
                            finally
                                ReleaseDC(0, DC);
                            end;
                        finally
                            FCanvas.Free;
                        end;
                    end;

                    with (Owner as TForm) do
                    begin
                        Color := FColor;
                        Borderstyle := bsNone;
                        FormStyle := fsStayOnTop;
                        SetWindowLong(Handle,GWL_EXSTYLE,GetWindowLong(Handle,GWL_EXSTYLE) or WS_EX_TOPMOST);
                        Caption := '';
                        BorderIcons := [];
                        Setbounds(0,0,Screen.Width,Screen.Height);
                    end;
                end;
            skChildPreview:
                begin
                    with (Owner as TForm) do
                    begin
                        Color := FColor;
                        Borderstyle := bsNone;
                        FormStyle := fsNormal;
                        Caption := '';
                        BorderIcons := [];
                    end;
                    CreateWrapper;
                end;
        end;

        if Assigned(FOnSaverStart) then FOnSaverStart(Application);

        {Important!!! - Initializing Saver for System...}
        HideCursor;

        if not PreviewMode then
        begin
            SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,Word(True),@Dummy,0);
            SystemParametersInfo(SPI_SCREENSAVERRUNNING,Word(True),@Dummy,0);
            SystemParametersInfo(SPI_SETFASTTASKSWITCH,Word(False),@Dummy,0);
            FSaverActive := True;
        end;

        Application.OnMessage := AppTest;
   end;
end;