全屏DirectX程序下弹出摸态窗口代码

鼯鼠

Delphi先锋论坛(http://www.topdelphi.net/bbs/index.asp)
--〖 delphi 〗(http://www.topdelphi.net/bbs/list.asp?boardid=1)
----全屏DirectX程序下弹出摸态窗口代码(http://www.topdelphi.net/bbs/dispbbs.asp?boardid=1&id=5046)
--作者：delphilxh
--发布时间：2004-1-14 16:35:55

--全屏DirectX程序下弹出摸态窗口代码
一直有人问如何在DirectX全屏游戏中弹出窗口就象金山游侠一样.我答应过要给出原码,只是一直没有时间整理,不过现在总算是弄玩了.代码不长,大致作了些注释,但愿你能看懂
按照我的说明一步步作应该就能成功,但有时可能不行,为什么?我也不知道,或许是你哪一步做错了,或者是Delphi的问题?天知道,但大多数时候按照我给出的步骤,这些代码应该能实现我们的目标.
下面的代码经过了一定的测试,但并没有刻意设计保证程序兼容性和稳定性的代码,所以不能保证在所有的机器上正常运行.如果死机或者花屏了,那么很不幸它不适合你,在找些别人写的类似的代码吧(不过以前有人公开过类似的代码吗?如果有请mail给我
试一试吧,希望我们能把它完善起来.
{***************HOOK.DLL************

FileName:Hook.dpr(The KEY unit to pop up a window in DX apps)

Author: tTui or tt.t (As u like ;)

Feature:This unit contain the Demo codes for pop up an MODAL window in Apps which use exclusive directX fullscreen mode.

Description: 1.Uses KeyBoard hook to hook the hotkey.
2.Uses s0me tricks to get the *real* IDirectDraw pointer.
3.Call the *IDirectDraw.FilptoGDISurface* to make sure the poped up window could be seen.(See MSDN for the reason)
4.Uses GetMessage hook to hook the WM_TIMER,WM_SETFOCUS... messages.(Why?I don\'t want to tell u Find the reason by urself)
5.The HotKey is Left WIN + NumPad *
6.Mute codes needed, but havn\'t wrote yet.
7.Complied with Delphi 6. Tested under Win98&SE, Win ME, Win 2K,Win XP and Win 2003.NET with DirectX 8&9.

Known Bugs:1.Cannot repaint the background when the poped up window moved.
2.May crash when try to pop up from some games and apps.
3.Cannot show the cursor in some games.
4.May minimize the main App, when try to pop up the window.
5.Many more...but unknown yet...

MY MAIL: ttui@163.com

BTW, if u want to pop up an MODALLESS window, u should write the codes all by urself.
*DO NOT* ask me for that.
***********************************}
library Hook;

uses
SysUtils,
Classes,
Windows,
Messages,
Dialogs,
DirectDraw,//*Modified* Jedi\'s DirectX header file for Delphi.
FormUnit in \'FormUnit.pas\' {Form1};//The unit contains the popup window.

{$R *.res}

type
PHookRec = ^THookRec;
THookRec = record
ParentWnd:HWND;//The main app\'s handle
FormWnd:HWND;//Handle of the popup window
Poped:Boolean; //A flag. eq True if the window poped
HH1:HHOOK; //Hook handle of the keyboard hook
HH2:HHOOK; //Hook handle of the GetMessage hook
end;

var
rHookRec: PHookRec = nil;
hMapObject: THandle = 0;

var
pDirectDrawCreate:function (lpGUID: PGUID;out lplpDD: IDirectDraw;pUnkOuter: IUnknown) : HResult; stdcall;

function WHGETMESSAGE(iCode:Integer;wParam: WPARAM;lParam: LPARAM)RESULT; stdcall;
begin
result:=0;
if iCode<0 then
begin
CallNextHookEx(rHookRec^.HH2,iCode,wParam,lParam);
result:=0;
Exit;
end;
case PMSG(lParam)^.message of
WM_TIMER, //$113
WM_WINDOWPOSCHANGING,//$47
WM_SETCURSOR, //$20
WM_ACTIVATEAPP,//$1c
WM_SETFOCUS://$7
begin //Some other messages should be processed here.
PMSG(lParam)^.message:=0;
end;
end;
end;

function HookProc(iCode:Integer;wParam: WPARAM;lParam: LPARAM)RESULT; stdcall;
var
dh:dword;
FD:IDirectDraw;
pp:pointer;
a:dword;
sc:integer;
begin
result:=0;
if iCode<0 then
begin
CallNextHookEx(rHookRec^.HH1,iCode,wParam,lParam);
result:=0;
Exit;
end;
if ((lParam and $80000000)=0) and
(GetKeyState(VK_LWIN)<0) and (wParam=$6a) then//The HotKey is Left WIN + NumPad *
begin
rHookRec^.ParentWnd:=getforegroundwindow;
if not ndow(rHookRec^.ParentWnd) then exit;
try
if not rHookRec^.Poped then
begin
dh:=GetModuleHandle(\'ddraw.dll\');//is a dx app??
if dh<>0 then
begin
dh:=dword(GetProcAddress(dh,\'DirectDrawCreate\'));
if dh<>0 then
begin
pDirectDrawCreate:=Pointer(dh);
if pDirectDrawCreate(nil,FD,nil)=0 then
begin
pp:=@fd;
a:=dword(pointer(dword(pp^)+8)^);//Now a is the pointer to the *REAL* IDirectDraw
asm //Call FliptoGDISurface
mov eax,a
push eax
mov eax,[eax]
call [eax+$28]
end;
FD:=nil;
end;
end;
end;
rHookRec^.HH2:=setwindowshookex(WH_GETMESSAGE,@WHGETMESSAGE,0,GetCurrentThreadID);
sc:=ShowCursor(true);//Show cursor
form1:=tform1.CreateParented(rHookRec^.ParentWnd); //Create the window that\'ll pop up
rHookRec^.Poped:=true;//set flag
rHookRec^.FormWnd:=form1.Handle;
form1.ShowModal;//Bingo!! The window pops up!!
form1.Free;
rHookRec^.Poped:=false;//set flag
UnhookWindowshookEx(rHookRec^.HH2);
if sc>=0 then
ShowCursor(true)
else
ShowCursor(false);
end;
finally

end;
result:=1;
end;
end;

function sethook:bool;export;//Call the func to set the keyboard hook
begin
result:=false;
if rHookRec^.HH1<>0 then exit;
rHookRec^.Poped:=False;
rHookRec^.HH1 := SetWindowsHookEx(WH_KEYBOARD,hookproc,HInstance,0);
Result := rHookRec^.HH1 <> 0;
end;

function endhook:bool;export;//Call the func to unhook the keyboard hook
begin
if rHookRec^.HH1 <> 0 then
begin
UnhookWindowshookEx(rHookRec^.HH1);
rHookRec^.HH1 := 0;
end;
Result := rHookRec^.HH1 = 0;
end;

procedure EntryPointProc(Reason: Integer);//Create and Close the file mapping to share data in different processes.
begin
case reason of
DLL_PROCESS_ATTACH:
begin
hMapObject := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, SizeOf(THookRec), \'_Popup_A_Wnd_DEMO_\');
rHookRec := MapViewOfFile(hMapObject, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(THookRec));
end;
DLL_PROCESS_DETACH:
begin
try
UnMapViewOfFile(rHookRec);
CloseHandle(hMapObject);
except
end;
end;
end;
end;

Exports
SetHook,
EndHook;

begin
DllProc := @EntryPointProc;
EntryPointProc(DLL_PROCESS_ATTACH);
end.
//==================================================
{*************FormUnit.pas**********

FileName:FormUnit.pas

Author: tTui or tt.t (As u like ;)

Description: This unit contains the codes of the popup window.

MY MAIL: ttui@163.com

TIPS:The form\'s BoaderStyle property must be "bsDialog" or the popup window may not be seen.

***********************************}
unit FormUnit;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject); //u can add other VCL components.
private
{ Private declarations }
procedure WndProc(var Message: TMessage); override;
public
{ Public declarations }
end;

type
PHookRec = ^THookRec;
THookRec = record
ParentWnd:HWND;
FormWnd:HWND;
Poped:Boolean;
HH1:HHOOK;
HH2:HHOOK;
end;

var
Form1: TForm1;
TILC_Message:Cardinal;//Exit message
rHookRec: PHookRec = nil;
hMapObject: THandle = 0;

implementation

{$R *.dfm}

procedure TForm1.WndProc(var Message: TMessage);
begin
inherited WndProc(Message);
if Message.Msg=TILC_Message then
Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
TILC_Message:=RegisterWindowMessage(pchar(\'Poooop!!\'));
hMapObject := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, SizeOf(THookRec), \'_Popup_A_Wnd_DEMO_\');
rHookRec := MapViewOfFile(hMapObject, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(THookRec));
// the popup window cann\'t access its handle via its property "form.handle" or an exception\'ll rise.
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
try
UnMapViewOfFile(rHookRec);
CloseHandle(hMapObject);
except
end;
end;

end.
//========================================
{***************Test.pas************

FileName:Test.pas

Author: tTui or tt.t (As u like ;)

Description: This unit demostrates how to use HOOK.DLL.
File->New->Application

MY MAIL: ttui@163.com

***********************************}
unit Test;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

function sethook:Bool;External \'Hook.DLL\';
function endhook:Bool;External \'Hook.DLL\';

var
Form1: TForm1;
TILC_Message:Cardinal;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
if Button1.Caption=\'SetHook\' then
begin
SetHook;
Button1.Caption:=\'EndHook\';
end
else
begin
Button1.Caption:=\'SetHook\';
EndHook;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
EndHook;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
TILC_Message:=RegisterWindowMessage(pchar(\'Poooop!!\'));
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
rWORD;
begin
r:=BSM_APPLICATIONS;
BroadcastSystemMessage(BSF_QUERY,@r,TILC_Message,0,0);//Broadcast the exit message when quit.
end;

end.
//===============================
Finally, we must modify the DirectDraw.pas to prevent to load the ddraw.dll when the application runs.
Find the initialization part at the end of DirectDraw.pas and add
"if false then" before "if not IsNTandDelphiRunning then".

Ok, everythig is ready.It\'s time to complie and launch it!
--作者：FTL123
--发布时间：2004-1-17 11:16:06

--
这个，需要把那个form1.ShowModal;//Bingo!! The window pops up!!改成from1.show不然游戏会静止掉哦！！把窗体改成最保持在最上面！！ --作者：delphilxh