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.

zusammenfalten · markieren

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

**SirThornberry**

dein Fehler liegt hier:

markieren

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:

markieren

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

**SirThornberry**

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

zusammenfalten · markieren

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:

markieren

Delphi-Quellcode:

			fMsgProcObj           := TNonVCLMsgProcObj.Create;

fMsgProcObj.SelfRef   := Self;

fMsgProcObj.WndMethod := WndProc;

und ins Destroy
fMsgProcObj.Free; und Anstelle von
WndClass.lpfnWndProc := @TWindow.WndProc; schreibst du einfach
WndClass.lpfnWndProc := fMsgProcObj.WndProc;

**SirThornberry**

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

zusammenfalten · markieren

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

Danke schön

Problem mit eigener Klasse und Fensterprozedur

Problem mit eigener Klasse und Fensterprozedur

Re: Problem mit eigener Klasse und Fensterprozedur

Re: Problem mit eigener Klasse und Fensterprozedur

Re: Problem mit eigener Klasse und Fensterprozedur

Re: Problem mit eigener Klasse und Fensterprozedur

Re: Problem mit eigener Klasse und Fensterprozedur

Forumregeln

Rastaman Registriert seit: 6. Jan 2005 Ort: Lübbecke 575 Beiträge Turbo C++	#3 Re: Problem mit eigener Klasse und Fensterprozedur 6. Jan 2006, 18:37 Danke, aber ich steig da ehrlich kein bisschen durch Chuck Norris has counted to infinity ... twice!
	Zitat

Rastaman Registriert seit: 6. Jan 2005 Ort: Lübbecke 575 Beiträge Turbo C++	#6 Re: Problem mit eigener Klasse und Fensterprozedur 7. Jan 2006, 19:40 Ich verstehs zwar nicht, aber es funktioniert Danke schön Chuck Norris has counted to infinity ... twice!
	Zitat