お知らせ

電子会議

ライブラリ

パレット

Delphi FAQ検索

Delphi FAQ一覧

サンプル蔵





FDelphi FAQ
16番会議室「玉石混淆みんなで作るSample蔵」に寄せられたサンプル

"スクリーンセーバー化"




フォームに貼り付けるだけでスクリーンセーバーになるコンポーネントです。

                                                     KHE00221 t.matsui

  
---------------------------------------------------------------------
unit ScreenServer;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
Dialogs,
  ExtCtrls;

type
  TInterruptType = (AppIdle,Timer);
  TScreenServer = class(TComponent)
  private
    //Property
    FInterruptType : TInterruptType;
    FInterval : Integer;
    FImage : TBitMap;
    FDeskTopImage : TBitMap;
    FPreViewImage : TBitMap;
    //Event
    FOnScreenServer : TNotifyEvent;
    FOnScreenServerCreate  : TNotifyEvent;
    FOnScreenServerDestroy : TNotifyEvent;
    FOnPreView : TNotifyEvent;
    FOnPreViewCreate : TNotifyEvent;
    FOnPreViewDestroy : TNotifyEvent;
    FOnOption : TNotifyEvent;
    FOnPassWord : TNotifyEvent;
    FIdleEvent : TIdleEvent;
    //DLL
    p : TFarProc;
    hPASSWORD : Integer;
    hMPR : Integer;
    PwdChangePasswordA : 
procedure(lpcregkeyname:LPCSTR;hwnd:HWND;uiReserved1:UINT;uiReserved2:
UINT); stdcall;
    VerifyScreenSavePwd : function (hwnd:HWND):Boolean;stdcall;
    //SubClass
    WHandle     : THandle;
    FOldWndProc : Pointer;
    FNewWndProc : Pointer;
    //Etc
    Form1 : TForm;
    Timer1 : TTimer;
    DC : HDC;
    DestRect : TRect;
    ParentHandle: HWND;
    Param : String;
    Buffer1,Buffer9 : array[0..99] of Char;
    //
  protected
    procedure StartAppIdle;
    procedure StopAppIdle;
    function  CheckPassWord():Boolean;
    procedure Form1AppIdle1(Sender: TObject; var Done: Boolean);
    procedure Form1AppIdle2(Sender: TObject; var Done: Boolean);
    procedure Form1AppIdle3(Sender: TObject; var Done: Boolean);
    procedure Form1Timer1(Sender: TObject);
    procedure Form1Timer2(Sender: TObject);
    procedure Form1Timer3(Sender: TObject);
    procedure WndProc(var Message: TMessage);virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;override;
    procedure Loaded;override;
    procedure Form1Show(Sender:TObject);
    procedure Form1MouseDown(Sender: TObject; Button: 
TMouseButton;Shift: TShiftState; X, Y: Integer);
    procedure Form1KeyPress(Sender: TObject; var Key: Char);
    property Image : TBitMap read FImage write FImage;
    property PreviewImage : TBitMap read FPreViewImage write 
FPreViewImage;
    property DeskTopImage : TBitMap read FDeskTopImage write 
FDeskTopImage;
  published
    property InterruptType : TinterruptType read FInterruptType write 
FInterruptType;
    property Interval : Integer read FInterval write FInterval;
    property OnScreenServer: TNotifyEvent read FOnScreenServer write 
FOnScreenServer;
    property OnScreenServerCreate: TNotifyEvent read 
FOnScreenServerCreate write FOnScreenServerCreate;
    property OnScreenServerDestroy: TNotifyEvent read 
FOnScreenServerDestroy write FOnScreenServerDestroy;
    property OnPreView: TNotifyEvent read FOnPreView write FOnPreView;
    property OnPreViewCreate: TNotifyEvent read FOnPreViewCreate write 
FOnPreViewCreate;
    property OnPreViewDestroy: TNotifyEvent read FOnPreViewDestroy 
write FOnPreViewDestroy;
    property OnOption:TNotifyEvent read FOnOption write FOnOption;
    property OnPassWord:TNotifyEvent read FOnPassWord write 
FOnPassWord;
  end;

procedure Register;

var
  Colors : array [0..15] of TColor =
  (clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, 
clDkGray,
   clLtGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, 
clWhite);
  B : Boolean;

implementation

{************************}
{*** 初期化と終了処理 ***}
{************************}
constructor TScreenServer.Create(AOwner:TComponent);
var
    Long : DWord;
begin
    inherited Create(AOwner);
    Interval := 100;
    if  Not(csDesigning in ComponentState) then
    begin
      //色々初期化
      Form1:= Owner as TForm;
      Param := Copy(UpperCase(ParamStr(1)),1,2);
      if Param='' then Param := '/C';
      if Param='/L' then Param := '/C';
      WHandle := 0;
      StrPCopy (Buffer9,Application.Title);
      //タイマーコンポーネントの動的作成
      Timer1 := TTimer.Create(Self);
      with Timer1 do
      begin
        Interval := 100;
        Name := 'ScreenServerTimer1';
        Enabled := False;
        OnTimer := nil;
      end;
      //Property : Image
      FImage := TBitMap.Create;
      with FImage,FImage.Canvas do
      begin
        Width  := Screen.Width;
        Height := Screen.Height;
        Brush.Color := clBlack;
        FillRect (Rect(0,0,Width,Height));
      end;
      //Property : PreViewImage
      FPreViewImage := TBitMap.Create;
      with FPreViewImage,FPreViewImage.Canvas do
      begin
        Width  := 100;
        Height := 100;
        Brush.Color := clBlack;
        FillRect (Rect(0,0,Width,Height));
      end;
      //Property : DeskTopImage
      FDeskTopImage := TBitMap.Create;
      with FDeskTopImage do
      begin
        Width  := Screen.Width;
        Height := Screen.Height;
        DC := GetDC(0);
        BitBlt (Canvas.Handle,0,0,Width,Height,DC,0,0,SRCCOPY);
        ReleaseDC(0,DC);
      end;
      //本稼動
      if Param = '/S' then
      begin
        ParentHandle := 0;
        with Form1 do
        begin
          Top     := 0;
          Left    := 0;
          Width   := Screen.Width;
          Height  := Screen.Height;
          BorderStyle := bsNone;
          FormStyle := fsStayOnTop;
        end;
        ShowCursor(False);
      end;
      //プレビュー
      if Param = '/P' then
      begin
        Form1.BorderStyle := bsNone;
        ParentHandle := StrToInt(ParamStr(2));
        Windows.SetParent (Form1.Handle,ParentHandle);
        Long := GetWindowLong (Form1.Handle,GWL_STYLE);
        Long := (Long and (not WS_POPUP)) or (WS_CHILD);
        SetWindowLong (Form1.Handle,GWL_STYLE,Long);
        GetWindowRect(ParentHandle,DestRect);
        with Form1 do
        begin
          Top    := 0;
          Left   := 0;
          Width  := DestRect.Right - DestRect.Left;
          Height := DestRect.Bottom - DestRect.Top;
        end;
        with FPreViewImage do
        begin
          Width  := DestRect.Right - DestRect.Left;
          Height := DestRect.Bottom - DestRect.Top;
        end;
        ShowCursor(False);
      end;

      //サブクラス化
      with TCustomForm(Owner) do
      begin
        WHandle:=Handle;
        FNewWndProc :=MakeObjectInstance(WndProc);
        FOldWndProc :=Pointer(GetWindowLong(WHandle, GWL_WNDPROC));
        SetWindowLong(WHandle, GWL_WNDPROC, Integer(FNewWndProc));
      end;

      //二重起動防止
      Form1.Caption := '';
      StrPCopy (Buffer1,'['+Form1.Name+']');
      if FindWindow(nil,Buffer1) <> 0 then
      begin
        Application.Terminate;
        Exit;
      end;
      Form1.Caption := '['+Form1.Name+']';
    end;
end;

procedure TScreenServer.Loaded;
var
    BitMap4 : TBitMap;
begin
    inherited Loaded;
    if  Not(csDesigning in ComponentState) then
    begin
      //環境設定
      if Param = '/C' then
      begin
        Application.ShowMainForm := False;
        if Assigned(OnOption) = True then OnOption(Self);
        Application.Terminate;
        Exit;
      end;
      //パスワード設定
      if Param = '/A' then
      begin
        Application.ShowMainForm := False;
        if Assigned(OnPassWord) = True then OnPassWord(Self) else
        begin
          ParentHandle := StrToInt(ParamStr(2));
          hMPR := LoadLibrary('MPR.DLL');
          p := GetProcAddress(hMPR, 'PwdChangePasswordA');
          if p <> Nil then @PwdChangePasswordA := p;
          PwdChangePasswordA('SCRSAVE',ParentHandle,0,0);
        end;
        Application.Terminate;
        Exit;
      end;

      if (Param='/P') then
      begin
        if(Assigned(OnPreView)) = True then
        begin
          BitMap4 := TBitMap.Create;
          with BitMap4 do
          begin
            Width  := PreViewImage.Width;
            Height := PreViewImage.Height;
          end;
          DestRect := Rect (0,0,BitMap4.Width,BitMap4.Height);
          BitMap4.Canvas.StretchDraw (DestRect,DeskTopImage);
          DeskTopImage.Width  := BitMap4.Width;
          DeskTopImage.Height := BitMap4.Height;
          DeskTopImage.Canvas.Draw (0,0,BitMap4);
          BitMap4.Free;
          if (Assigned(OnPreviewCreate) = True) then 
OnPreViewCreate(Self);
        end
        else
        begin
          if (Assigned(OnScreenServerCreate) = True) then 
OnScreenServerCreate(Self);
        end;
        if Assigned(Form1.OnShow) = False then
        begin
          Form1.OnShow := Form1Show;
        end;
      end;

      if (Param='/S') then
      begin
        if (Assigned(OnScreenServerCreate) = True) then 
OnScreenServerCreate(Self);
        if Assigned(Form1.OnMouseDown) = False then Form1.OnMouseDown 
:= Form1MouseDown;
        if Assigned(Form1.OnKeyPress)  = False then Form1.OnKeyPress :
= Form1KeyPress;
      end;


Original document by t.matsui        氏 ID:(KHE00221)


ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。

Copyright 1996-2002 Delphi Users' Forum