找到一个文章，晚上回家看，别打不开呀。

问题：分享:全屏DirectX程序下弹出摸态窗口代码 ( 积分：0, 回复：10, 阅读：1082 )
分类：系统相关 ( 版主：luyear, zyy04 )
来自：tt.t, 时间：2003-8-26 21:05:00, ID：2135796 [显示：小字体 | 大字体]

http://www.delphibbs.com/delphibbs/dispq.asp?lid=2135796
 
一直有人问如何在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):LRESULT; 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):LRESULT; 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 isWindow(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
  r:DWORD;
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!  

posted @ 2007-02-12 15:52  云水浮萍  阅读(768)  评论(0)  编辑  收藏  举报