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