Problem mit eigener Klasse und Fensterprozedur

[Rastaman]

Nabend, hab da ein kleines Problem.
Ich wollte nämlich einen kleinen VCL Ersatz schreiben, so dass man leicht nonVCL (Kann man das dann noch sagen?) Programme hinbekommt, so ähnlich halt wie mit der VCL, nur kleiner.
Dazu wollt ich erstma mit der Forms unit anfangen, klappt aber an einer Stelle nicht so toll.
Hier ma der bis jetz ziemlich kleine Code.

Delphi-Quellcode:

unit NonVCLForms;

interface

uses
  Windows, Messages;

type
  TPosition = (poNone, poCenter);

  TWndStyle = packed record
    Left, Top, Width, Height: Integer;
    Caption: PChar;
    Color: Cardinal;
    Position: TPosition;
  end;

  TWindow = class
  private
    { Private-Deklarationen }
    type
      TNotifyEvent = procedure of object;
    var
      FHandle: HWND;
      FOnCreate: TNotifyEvent;
      WndClass: TWndClassEx;
    procedure CenterWindow(wndParent, wndChild: HWND);
  public
    { Public-Deklarationen }
    constructor Create(WndStyle: TWndStyle);
    function WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM;
      lParam: LPARAM): LRESULT; stdcall;
  published
    property Handle: HWND read FHandle;
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
  end;

implementation

(* Private *)

(* Zentriert ein Fenster anhand seines Parents *)
procedure TWindow.CenterWindow(wndParent, wndChild: HWND);
var
  PRec,
  CRec: TRect;
begin
  // Fensterkoordinaten ins TRect laden
  GetClientRect(WndParent, PRec);
  GetClientRect(WndChild, CRec);
  // Parent muss größer sein als Child
  if ((PRec.Right - PRec.Left) < (CRec.Right - CRec.Left)) or
     ((PRec.Bottom - PRec.Top) < (CRec.Bottom - CRec.Top)) then
  begin
    Exit;
  end;
  // Position setzen
  SetWindowPos(WndChild, HWND_TOP, (PRec.Right - CRec.Right) div 2,
    (PRec.Bottom - CRec.Bottom) div 2, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE);
end;

(* Public *)

constructor TWindow.Create(WndStyle: TWndStyle);
var
  lgBr: TLogBrush;
  hBr: HBRUSH;
begin

  case WndStyle.Color of
    COLOR_WINDOW,
    COLOR_APPWORKSPACE:
      begin
        lgBr.lbColor := GetSysColor(WndStyle.Color);
      end;
  else
    lgBr.lbColor := WndStyle.Color;
  end;
  lgBr.lbStyle := BS_SOLID;
  hBr := CreateBrushIndirect(lgBr);

  WndClass.cbSize := SizeOf(WndClass);
  WndClass.style := CS_OWNDC;
  WndClass.lpfnWndProc := @TWindow.WndProc;
  WndClass.hInstance := hInstance;
  WndClass.hCursor := LoadCursor(0, IDC_ARROW);
  WndClass.hbrBackground := hBr;
  WndClass.lpszClassName := 'TWindow';
  RegisterClassEx(WndClass);

  With WndStyle do
  begin
    FHandle := CreateWindow('TWindow', Caption, WS_VISIBLE or WS_SYSMENU,
                 Left, Top, Width, Height, 0, 0, hInstance, nil);

    if Position = poCenter then
      CenterWindow(FindWindow('ProgMan', nil), Handle);
  end;

end;

function TWindow.WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
begin
  case uMsg of
    WM_CREATE:
      begin
        if Assigned(OnCreate) then
          OnCreate;
        Result := 0;
      end;
  else
    Result := DefWindowProc(hwnd, uMsg, wParam, lParam);
  end;
end;

end.

Das Problem liegt da, wo der Fensterklasse die Fensterprozedur übermittelt wird.
Das Fenster taucht einfach nicht auf. Wenn ich nur @WndProc schreibe, kommt der Fehler "Variable erwartet", und wenn ich die Prozedur aus der TWindow Klasse rausnehme, klappt es zwar, aber ich kann dann ja halt auch keine Ereignisse wie "OnCreate" zuweisen. Was könnte man da machen :gruebel:

[SirThornberry]

dein Fehler liegt hier:

Delphi-Quellcode:

function TWindow.WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM; 
  lParam: LPARAM): LRESULT; stdcall;

Deine Funktion entspricht nicht dem wie es laut msdn sein muss. Deine Funktion ist vom Typ Object und sieht somit intern so aus:

Delphi-Quellcode:

function WndProc(Self: TObject; hwnd: HWND; uMsg: UINT; wParam: WPARAM; 
  lParam: LPARAM): LRESULT; stdcall;

Sie hat also einen Parameter mehr!

Im Anhang befindet sich ein Beispiel wie man das richtig machen kann. Dabei wird für jede Instanz eine WindowProc erzeugt (der Assemblercode) und in diese Windowproc fest das Self mit reingeschrieben. Diese WindowProc ruft dann wiederum die WindowProc-Methode des Objects auf mit dem Self-Parameter. Beim Destroy des Objectes wird dann die dynamisch erzeugte WindowProc auch wieder frei gegeben.

Du benötigst aus dieser Unit also eigentlich nur die Klasse "TNonVCLMsgProcObj". Diese erzeugt dynamisch die WndProc und leitet von dort aus auf deine WndProc-Methode um.

[Rastaman]

Danke, aber ich steig da ehrlich kein bisschen durch :wall:

[SirThornberry]

du musst dir folgendes raus kopieren und am besten in eine eigene unit kopieren:

Delphi-Quellcode:

type
  TObjWndProc = function(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult of Object;
  TNonVCLMsgProcObj = class(TObject)
  private
    fAllocedMem: Pointer;
    fMethodRef: TObjWndProc;
    fSelfRef: TObject;
    procedure FSetMethodRef(ARef: TObjWndProc);
    procedure FSetSelfRef(ARef: TObject);
  public
    constructor Create(ASelfRef: TObject=nil; AMethod: TObjWndProc=nil);
    destructor Destroy; override;

    property SelfRef: TObject read fSelfRef write FSetSelfRef default nil;
    property WndProc: Pointer read fAllocedMem;
    property WndMethod: TObjWndProc read fMethodRef write FSetMethodRef default nil;
  end;
[...]
{==============================================================================}
{============================= TNonVCLObjMsgProc ==============================}
{==============================================================================}

constructor TNonVCLMsgProcObj.Create(ASelfRef: TObject; AMethod: TObjWndProc);
  procedure LWrite(AVal: Integer; var APtr: Pointer; ASize: Integer);
  begin
    move(AVal, APtr^, ASize);
    inc(Integer(APtr), ASize);
  end;
var LPtr: Pointer;
begin
  inherited Create;
  fMethodRef := AMethod;
  fSelfRef   := ASelfRef;
  //erstellt folgende Funktion im speicher
  {
  function LTmpProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LRESULT; stdcall;
  type
    TObjWndProc = function(Self: Pointer; wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult;
  var LObjProc: TObjWndProc;
      LSelfRef: Pointer;
  begin
    LObjProc := [ASELF];
    LSelfRef := [AProc];
    result := LObjProc(LSelfRef, wnd, uMsg, wp, lp);
  end;
  }
  LPtr := VirtualAlloc(nil, 4096, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  fAllocedMem := LPtr;
  //Begin
  LWrite($55, LPtr, 1);
  LWrite($EC8B, LPtr, 2);
  LWrite($53, LPtr, 1);
  //LObjProc zuweisen
  LWrite($B8, LPtr, 1);
  LWrite(Integer(@fMethodRef), LPtr, 4);
  //LSelfProc zuwiesen
  LWrite($BA, LPtr, 1);
  LWrite(Integer(fSelfRef), LPtr, 4);
  //Aufruf
  LWrite($104D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($144D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($D88B, LPtr, 2);
  LWrite($0C4D8B, LPtr, 3);
  LWrite($C28B, LPtr, 2);
  LWrite($08558B, LPtr, 3);
  LWrite($D3FF, LPtr, 2);

  //end
  LWrite($5B, LPtr, 1);
  LWrite($5D, LPtr, 1);
  LWrite($0010C2, LPtr, 3);
  LWrite($90, LPtr, 1);
end;

{==============================================================================}

destructor TNonVCLMsgProcObj.Destroy;
begin
  VirtualFree(fAllocedMem, 0, MEM_RELEASE);
  inherited Destroy;
end;

{==============================================================================}

procedure TNonVCLMsgProcObj.FSetMethodRef(ARef: TObjWndProc);
var LAddr: Pointer;
begin
  if @fMethodRef <> @ARef then
  begin
    fMethodRef := ARef;
    LAddr := Pointer(Integer(fAllocedMem) + 5);
    move(Pointer(@@fMethodRef)^, LAddr^, 4);
  end;
end;

{==============================================================================}

procedure TNonVCLMsgProcObj.FSetSelfRef(ARef: TObject);
var LAddr: Pointer;
begin
  if @fSelfRef <> @ARef then
  begin
    fSelfRef := ARef;
    LAddr := Pointer(Integer(fAllocedMem) + 10);
    move(Pointer(@fSelfRef)^, LAddr^, 4);
  end;
end;

Dieses Object dient dazu die MsgProc auf eine MsgMethode umzuleiten.

Du musst dann also noch ins Create von deiner Eigenen WindowKlasse folgendes schreiben:

Delphi-Quellcode:

fMsgProcObj           := TNonVCLMsgProcObj.Create;
fMsgProcObj.SelfRef   := Self;
fMsgProcObj.WndMethod := WndProc;

und ins Destroy

Delphi-Quellcode:

fMsgProcObj.Free;

und Anstelle von

Delphi-Quellcode:

WndClass.lpfnWndProc := @TWindow.WndProc;

schreibst du einfach

Delphi-Quellcode:

WndClass.lpfnWndProc := fMsgProcObj.WndProc;

[SirThornberry]

aus langer weile habe ich mal von deinem ersten Post den Source genommen und das von mir beschriebene eingearbeitet:

Delphi-Quellcode:

unit NonVCLForms;

interface 

uses 
  Windows, Messages; 

type
  TObjWndProc = function(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult of Object;

  TNonVCLMsgProcObj = class(TObject)
  private
    fAllocedMem: Pointer;
    fMethodRef: TObjWndProc;
    fSelfRef: TObject;
    procedure FSetMethodRef(ARef: TObjWndProc);
    procedure FSetSelfRef(ARef: TObject);
  public
    constructor Create(ASelfRef: TObject=nil; AMethod: TObjWndProc=nil);
    destructor Destroy; override;

    property SelfRef: TObject read fSelfRef write FSetSelfRef default nil;
    property WndProc: Pointer read fAllocedMem;
    property WndMethod: TObjWndProc read fMethodRef write FSetMethodRef default nil;
  end;


  TPosition = (poNone, poCenter);

  TWndStyle = packed record
    Left, Top, Width, Height: Integer;
    Caption: PChar;
    Color: Cardinal;
    Position: TPosition;
  end;

  TWindow = class
  private 
    { Private-Deklarationen } 
    type 
      TNotifyEvent = procedure of object; 
    var 
      FHandle: HWND;
      FMsgProcObj: TNonVCLMsgProcObj;
      FOnCreate: TNotifyEvent; 
      WndClass: TWndClassEx; 
    procedure CenterWindow(wndParent, wndChild: HWND); 
  public 
    { Public-Deklarationen }
    constructor Create(WndStyle: TWndStyle);
    destructor Destroy; override;
    function WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM;
      lParam: LPARAM): LRESULT;
  published 
    property Handle: HWND read FHandle; 
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; 
  end; 

implementation

{==============================================================================}
{============================= TNonVCLObjMsgProc ==============================}
{==============================================================================}

constructor TNonVCLMsgProcObj.Create(ASelfRef: TObject; AMethod: TObjWndProc);
  procedure LWrite(AVal: Integer; var APtr: Pointer; ASize: Integer);
  begin
    move(AVal, APtr^, ASize);
    inc(Integer(APtr), ASize);
  end;
var LPtr: Pointer;
begin
  inherited Create;
  fMethodRef := AMethod;
  fSelfRef   := ASelfRef;
  //erstellt folgende Funktion im speicher
  {
  function LTmpProc(wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LRESULT; stdcall;
  type
    TObjWndProc = function(Self: Pointer; wnd: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): LResult;
  var LObjProc: TObjWndProc;
      LSelfRef: Pointer;
  begin
    LObjProc := [ASELF];
    LSelfRef := [AProc];
    result := LObjProc(LSelfRef, wnd, uMsg, wp, lp);
  end;
  }
  LPtr := VirtualAlloc(nil, 4096, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
  fAllocedMem := LPtr;
  //Begin
  LWrite($55, LPtr, 1);
  LWrite($EC8B, LPtr, 2);
  LWrite($53, LPtr, 1);
  //LObjProc zuweisen
  LWrite($B8, LPtr, 1);
  LWrite(Integer(@fMethodRef), LPtr, 4);
  //LSelfProc zuwiesen
  LWrite($BA, LPtr, 1);
  LWrite(Integer(fSelfRef), LPtr, 4);
  //Aufruf
  LWrite($104D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($144D8B, LPtr, 3);
  LWrite($51, LPtr, 1);
  LWrite($D88B, LPtr, 2);
  LWrite($0C4D8B, LPtr, 3);
  LWrite($C28B, LPtr, 2);
  LWrite($08558B, LPtr, 3);
  LWrite($D3FF, LPtr, 2);

  //end
  LWrite($5B, LPtr, 1);
  LWrite($5D, LPtr, 1);
  LWrite($0010C2, LPtr, 3);
  LWrite($90, LPtr, 1);
end;

{==============================================================================}

destructor TNonVCLMsgProcObj.Destroy;
begin
  VirtualFree(fAllocedMem, 0, MEM_RELEASE);
  inherited Destroy;
end;

{==============================================================================}

procedure TNonVCLMsgProcObj.FSetMethodRef(ARef: TObjWndProc);
var LAddr: Pointer;
begin
  if @fMethodRef <> @ARef then
  begin
    fMethodRef := ARef;
    LAddr := Pointer(Integer(fAllocedMem) + 5);
    move(Pointer(@@fMethodRef)^, LAddr^, 4);
  end;
end;

{==============================================================================}

procedure TNonVCLMsgProcObj.FSetSelfRef(ARef: TObject);
var LAddr: Pointer;
begin
  if @fSelfRef <> @ARef then
  begin
    fSelfRef := ARef;
    LAddr := Pointer(Integer(fAllocedMem) + 10);
    move(Pointer(@fSelfRef)^, LAddr^, 4);
  end;
end;

{==============================================================================}
{==============================================================================}
{==============================================================================}

(* Private *) 

(* Zentriert ein Fenster anhand seines Parents *) 
procedure TWindow.CenterWindow(wndParent, wndChild: HWND); 
var 
  PRec, 
  CRec: TRect; 
begin 
  // Fensterkoordinaten ins TRect laden 
  GetClientRect(WndParent, PRec); 
  GetClientRect(WndChild, CRec); 
  // Parent muss größer sein als Child 
  if ((PRec.Right - PRec.Left) < (CRec.Right - CRec.Left)) or 
     ((PRec.Bottom - PRec.Top) < (CRec.Bottom - CRec.Top)) then 
  begin 
    Exit; 
  end; 
  // Position setzen 
  SetWindowPos(WndChild, HWND_TOP, (PRec.Right - CRec.Right) div 2, 
    (PRec.Bottom - CRec.Bottom) div 2, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE); 
end; 

(* Public *) 

constructor TWindow.Create(WndStyle: TWndStyle); 
var 
  lgBr: TLogBrush; 
  hBr: HBRUSH; 
begin
  FMsgProcObj := TNonVCLMsgProcObj.Create(Self, WndProc);

  case WndStyle.Color of 
    COLOR_WINDOW, 
    COLOR_APPWORKSPACE: 
      begin 
        lgBr.lbColor := GetSysColor(WndStyle.Color); 
      end; 
  else 
    lgBr.lbColor := WndStyle.Color; 
  end; 
  lgBr.lbStyle := BS_SOLID; 
  hBr := CreateBrushIndirect(lgBr); 

  WndClass.cbSize := SizeOf(WndClass); 
  WndClass.style := CS_OWNDC;

  WndClass.lpfnWndProc := FMsgProcObj.WndProc;
  WndClass.hInstance := hInstance; 
  WndClass.hCursor := LoadCursor(0, IDC_ARROW); 
  WndClass.hbrBackground := hBr; 
  WndClass.lpszClassName := 'TWindow'; 
  RegisterClassEx(WndClass); 

  With WndStyle do 
  begin 
    FHandle := CreateWindow('TWindow', Caption, WS_VISIBLE or WS_SYSMENU, 
                 Left, Top, Width, Height, 0, 0, hInstance, nil); 

    if Position = poCenter then 
      CenterWindow(FindWindow('ProgMan', nil), Handle); 
  end; 

end;

destructor TWindow.Destroy;
begin
  if (FHandle <> 0) then
    DestroyWindow(FHandle);
  FMsgProcObj.Free; 
  inherited Destroy; 
end;


function TWindow.WndProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT;
begin 
  case uMsg of 
    WM_CREATE: 
      begin 
        if Assigned(OnCreate) then 
          OnCreate; 
        Result := 0; 
      end; 
  else 
    Result := DefWindowProc(hwnd, uMsg, wParam, lParam); 
  end; 
end; 

end.

In diesem Schritt hab ich das Destroy mit überschrieben in dem das erzeugte Fenster auch wieder frei gegeben wird!

[Rastaman]

Ich verstehs zwar nicht, aber es funktioniert :mrgreen:
Danke schön :thumb: