您现在的位置:首页 >> VCL >> VCL >> 内容

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.

作者:网络 来源:转载
共有评论 0相关评论
发表我的评论
  • 大名:
  • 内容:
本类推荐
  • 没有
本类固顶
  • 没有
  • 盒子文章(www.2ccc.com) © 2020 版权所有 All Rights Reserved.
  • 沪ICP备05001939号