Виртуальная библиотека Delphi

Function CreateScreenSaverWindow(Width,Height : Integer; ParentWindow : hWnd) : hWnd;

Var WC : TWndClass;

Begin

With WC do Begin

Style := cs_ParentDC;

lpfnWndProc := @PreviewWndProc;

cbClsExtra := 0; cbWndExtra := 0; hIcon := 0; hCursor := 0;

hbrBackground := 0; lpszMenuName := nil;

lpszClassName := 'MyDelphiScreenSaverClass';

hInstance := System.hInstance;

end;

RegisterClass(WC);

If (ParentWindow 0) Then

Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',

ws_Child Or ws_Visible or ws_Disabled,0,0,

Width,Height,ParentWindow,0,hInstance,nil)

Else Begin

Result := CreateWindow('MyDelphiScreenSaverClass','MySaver',

ws_Visible or ws_Popup,0,0,Width,Height, 0,0,hInstance,nil);

SetWindowPos(Result,hwnd_TopMost,0,0,0,0,swp_NoMove or swp_NoSize or swp_NoRedraw);

End;

PreviewWindow := Result;

End;

Теперь окна созданы используя вызовы API. Я удалил проверку ошибки, но обычно все проходит хорошо, особенно в этом типе приложения.

Теперь Вы можете погадать, как мы получим handle родительского окна предварительного просмотра ? В действительности, это совсем просто: Windows просто передает handle в командной строке, когда это нужно. Таким образом:

Procedure RunPreview;

Var

R : TRect;

PreviewWindow : hWnd;

Msg : TMsg;

Dummy : Integer;

Begin

IsPreview := True;

PreviewWindow := StrToInt(ParamStr(2));

GetWindowRect(PreviewWindow,R);

CreateScreenSaverWindow(R.Right-R.Left,R.Bottom-R.Top,PreviewWindow);

CreateThread(nil,0,@PreviewThreadProc,nil,0,Dummy);

While GetMessage(Msg,0,0,0) do Begin

TranslateMessage(Msg); DispatchMessage(Msg);

End;

End;

Как Вы видите, window handle является вторым параметром (после "-p").

Чтобы "выполнять" хранителя экрана — нам нужна нить. Это создается с вышеуказанным CreateThread. Процедура нити выглядит примерно так:

Function PreviewThreadProc(Data : Integer) : Integer; StdCall;

Var R : TRect;

Begin

Result := 0; Randomize;

GetWindowRect(PreviewWindow,R);

MaxX := R.Right-R.Left; MaxY := R.Bottom-R.Top;

ShowWindow(PreviewWindow,sw_Show); UpdateWindow(PreviewWindow);

Repeat

InvalidateRect(PreviewWindow,nil,False);

Sleep(30);

Until QuitSaver;

PostMessage(PreviewWindow,wm_Destroy,0,0);

End;

Нить просто заставляет обновляться изображения в нашем окне, спит на некоторое время, и обновляет изображения снова. А Windows будет посылать сообщение WM_PAINT на наше окно (не в нить !). Для того, чтобы оперировать этим сообщением, нам нужна процедура:

Function PreviewWndProc(Window : hWnd; Msg,WParam, LParam : Integer): Integer; StdCall;

Begin

Result := 0;

Case Msg of

wm_NCCreate : Result := 1;

wm_Destroy : PostQuitMessage(0);

wm_Paint : DrawSingleBox; { paint something }

wm_KeyDown : QuitSaver := AskPassword;

wm_LButtonDown, wm_MButtonDown, wm_RButtonDown, wm_MouseMove :

Begin

If (Not IsPreview) Then Begin

Dec(MoveCounter);

If (MoveCounter <= 0) Then QuitSaver := AskPassword;

End;

End;

Else Result := DefWindowProc(Window,Msg,WParam,LParam);

End;

End;

Если мышь перемещается, кнопка нажала, мы спрашиваем у пользователя пароль:

Function AskPassword : Boolean;

Var

Key : hKey;

D1,D2 : Integer; { two dummies }

Value : Integer;

Lib : THandle;

F : 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

@F := GetProcAddress(Lib,'VerifyScreenSavePwd');

ShowCursor(True);

If (@F nil) Then Result := F(PreviewWindow);

ShowCursor(False);

MoveCounter := 3; { reset again if password was wrong }

FreeLibrary(Lib);

End;

End;

End;

RegCloseKey(Key);

End;

End;

Это также демонстрирует использование registry на уровне API. Также имейте в виду как мы динамически загружаем функции пароля, используюя LoadLibrary. Запомните тип функции?

TVSSFunc ОПРЕДЕЛЕН как:

Type

TVSSPFunc = Function(Parent : hWnd) : Bool; StdCall;

Теперь почти все готово, кроме диалога конфигурации. Это запросто:

Procedure RunSettings;

Var Result : Integer;

Begin

Result := DialogBox(hInstance,'SaverSettingsDlg',0,@SettingsDlgProc);

If (Result = idOK) Then SaveSettings;

End;

Трудная часть — это создать диалоговый сценарий (запомните: мы не используем здесь Delphi формы!). Я сделал это, используя 16-битовую Resource Workshop (остался еще от Turbo Pascal для Windows). Я сохранил файл как сценарий (текст), и скомпилированный это с BRCC32:

SaverSettingsDlg DIALOG 70, 130, 166, 75

STYLE WS_POPUP | WS_DLGFRAME | WS_SYSMENU

CAPTION "Settings for Boxes"

FONT 8, "MS Sans Serif"

BEGIN

DEFPUSHBUTTON "OK", 5, 115, 6, 46, 16

PUSHBUTTON "Cancel", 6, 115, 28, 46, 16

CTEXT "Box &Color:", 3, 2, 30, 39, 9

COMBOBOX 4, 4, 40, 104, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS

CTEXT "Box &Type:", 1, 4, 3, 36, 9

COMBOBOX 2, 5, 12, 103, 50, CBS_DROPDOWNLIST | CBS_HASSTRINGS

LTEXT "Boxes Screen Saver for Win32 Copyright (c) 1996 Jani Järvinen.", 7, 4, 57, 103, 16, WS_CHILD | WS_VISIBLE | WS_GROUP

END

Почти также легко сделать диалоговое меню:

Function SettingsDlgProc(Window : hWnd; Msg,WParam,LParam : Integer): Integer; StdCall;

Var S : String;

Begin

Result := 0;

Case Msg of

wm_InitDialog : Begin

{ initialize the dialog box }

Result := 0;

End;

wm_Command : Begin

If (LoWord(WParam) = 5) Then EndDialog(Window,idOK)

Else If (LoWord(WParam) = 6) Then EndDialog(Window,idCancel);

End;

wm_Close : DestroyWindow(Window);

wm_Destroy : PostQuitMessage(0);

Else Result := 0;

End;

End;

После того, как пользователь выбрал некоторые установочные параметры, нам нужно сохранить их.

Procedure SaveSettings;

Var

Key : hKey;

Dummy : Integer;

Begin

If (RegCreateKeyEx(hKey_Current_User,

'Software\SilverStream\SSBoxes',

0,nil,Reg_Option_Non_Volatile,

Key_All_Access,nil,Key,

@Dummy) = Error_Success) Then Begin

RegSetValueEx(Key,'RoundedRectangles',0,Reg_Binary,

@RoundedRectangles,SizeOf(Boolean));

RegSetValueEx(Key,'SolidColors',0,Reg_Binary, @SolidColors,SizeOf(Boolean));

RegCloseKey(Key);

End;

End;

Загружаем параметры так:

Procedure LoadSettings;

Var

Key : hKey;

D1,D2 : Integer; { two dummies }

Value : Boolean;

Begin

If (RegOpenKeyEx(hKey_Current_User,

'Software\SilverStream\SSBoxes',0,

Key_Read, Key) = Error_Success) Then Begin

D2 := SizeOf(Value);

If (RegQueryValueEx(Key,'RoundedRectangles',nil,@D1, @Value, @D2) = Error_Success) Then Begin

RoundedRectangles := Value;

End;

If (RegQueryValueEx(Key,'SolidColors',nil,@D1, @Value,@D2) = Error_Success) Then Begin

SolidColors := Value;

End;

RegCloseKey(Key);

End;

End;

Легко? Нам также нужно позволить пользователю установить пароль. Я честно не знаю почему это оставлено разработчику приложений? Тем не менее:

Procedure RunSetPassword;

Var

Lib : THandle;

F : TPCPAFunc;

Begin

Lib := LoadLibrary('MPR.DLL');

If (Lib > 32) Then Begin

@F := GetProcAddress(Lib,'PwdChangePasswordA');

If (@F nil) Then F('SCRSAVE',StrToInt(ParamStr(2)),0,0);

FreeLibrary(Lib);

End;

End;

Мы динамически загружаем (недокументированную) библиотеку MPR.DLL, которая имеет функцию, чтобы установить пароль хранителя экрана, так что нам не нужно беспокоиться об этом.