Delphi从普通对象方法转换到回调函数

时间：2011/9/3 16:26:10 点击：

　　核心提示：今天从网上找到一个讲的清楚点的，自己实践了一下。写下这个单元： Unit UntMakeInstruction;interfaceuses SysUtils;type //Importance: T...

今天从网上找到一个讲的清楚点的，自己实践了一下。写下这个单元：
Unit UntMakeInstruction;

interface

uses
SysUtils;

type
//Importance: The method must use stdcall calling method.
//Generate instruction
pInstruction = ^TInstruction;
TInstruction = packed record            //Total Size:           16 bytes
    SaveCode: array[0..6] of byte;        //Save old information   7 bytes
    Instance: Pointer;                    //Object Instance        4 bytes
    JmpCode : byte;                       //Jump code              1 bytes
    Method : Pointer;                    //Jump address           4 bytes
end;

function MakeInstruction(AMethod: TMethod): Pointer;
procedure FreeInstruction(APtr: Pointer);

implementation
{
push [ESP]
mov   [ESP+4], ObjectAddr
jmp   MethodAddr
}
function MakeInstruction(AMethod: TMethod): Pointer;
const
Code: array[0..15] of byte = ($FF, $34, $24, $C7, $44, $24, $04, $00,
                                $00, $00, $00, $E9, $00, $00, $00, $00);
var
m_Ptr: pInstruction;
begin
new(m_Ptr);

Move(Code, m_Ptr^, SizeOf(Code));
m_Ptr^.Instance:= AMethod.Data;
m_Ptr^.Method := Pointer(LongInt(AMethod.Code) - (LongInt(m_Ptr) + SizeOf(Code)));

Result:= m_Ptr;
end;

procedure FreeInstruction(APtr: Pointer);
begin
Dispose(APtr);
end;

end.

测试窗体：

unit Unit1;

interface

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

type
TForm1 = class(TForm)
    Panel1: TPanel;
    btnTest: TButton;
    procedure btnTestClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

private
    { Private declarations }
    FOldWndProc: Integer;
    FMethod: Pointer;

function NewWndProc(AHandle: THandle; AMsg: UINT; wpar, lPar: LongInt): integer; stdcall;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses
UntMakeInstruction;

{$R *.dfm}

{ TTestCls }

procedure TForm1.btnTestClick(Sender: TObject);
var
m_Method: TMethod;
begin
m_Method.Code:= @TForm1.NewWndProc;
m_Method.Data:= Self;
FMethod:= MakeInstruction(m_Method);
FOldWndProc:= SetWindowLong(Panel1.Handle, GWL_WNDPROC, Integer(FMethod));

Panel1.Refresh;

btnTest.Enabled:= false;
end;

function TForm1.NewWndProc(AHandle: THandle; AMsg: UINT; wpar,
lPar: Integer): integer;
var
m_Rect: TRect;
m_hDC : HDC;
begin
Result:= CallWindowProc(Pointer(FOldWndProc), AHandle, AMsg, wPar, lPar);

case AMsg of
WM_PAINT:
begin
GetWindowRect(AHandle, m_Rect);
m_hDC:= GetWindowDC(AHandle);

    try
      Rectangle(m_hDC, 0, 0, m_Rect.Right - m_Rect.Left, m_Rect.Bottom - m_Rect.Top);
    finally
      ReleaseDC(AHandle, m_hDC);
    end;
end;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if FMethod <> nil then
begin
SetWindowLong(Panel1.Handle, GWL_STYLE, FOldWndProc);

FreeInstruction(FMethod); //好像这里有问题，调整后再修改吧
end;
end;

end.