[nonVCL] Subclassing eines StcCtrl's / falscher Font...

[turboPASCAL]

Hi,

ich möchte in einem Dialogfenster ein Staticcontrol subclassen. Leider wird nicht wie ich
dachte der an das Staticcontrol, ein Statictext, der von mir gesetzte Font verwendet sondern
der Systemfont.
Wenn man SetWindowLong auskommentiert ist der gewünschte Font richtig gesetzt worden.

Habe ich was übersehen ?

Delphi-Quellcode:

program Test;

{$R '_res\resources.res' '_res\resources.rc'}

uses
  Windows, Messages;

const
  IDD_MAINDLG   = 100;
  IDC_STC1      = 101;
  MyText       = 'Hellow !';

var
  OldProc: Pointer;
  _Font: HFONT;

function WndProc(hWnd: HWND; uMsg: UINT; wParam, lParam: Integer): LRESULT; stdcall;
var
  ps: PAINTSTRUCT;
  DC: HDC;
  r: trect;
begin
  Result := 0;

  case uMsg of
    WM_PAINT:
      begin
        DC := BeginPaint(hWnd, ps);
        SetBkMode(DC, TRANSPARENT);

        GetClientRect(hWnd, r);
        windows.FrameRect(DC, r, GetStockObject(WHITE_BRUSH));
        DrawText(DC, PChar(MyText), length(MyText), r,
          DT_SINGLELINE   or DT_NOPREFIX or DT_CENTER or DT_VCENTER);

        EndPaint(hWnd, ps);
      end;
    else
      Result := CallWindowProc(OldProc, hWnd, uMsg, wParam, lParam);
  end;
end;

function DialogProc(hDlg: HWND; uMsg: UINT; wParam, lParam: Integer): BOOL; stdcall;
begin
  Result := TRUE;

  case uMsg of
    WM_INITDIALOG:
      begin
        _Font := CreateFont(-24, 0, 0, 0, FW_BOLD, 0, 0, 0,
          ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
          DEFAULT_PITCH, 'arial');
        SendMessage(GetDlgItem(hDlg, IDC_STC1), WM_SETFONT, Integer(_Font), 0);

        OldProc := Pointer(GetWindowLong(GetDlgItem(hDlg, IDC_STC1), GWL_WNDPROC));
        
        //* 
        SetWindowLong(GetDlgItem(hDlg, IDC_STC1), GWL_WNDPROC, Integer(@WndProc));
      end;

    WM_CLOSE: DestroyWindow(hDlg);
    WM_DESTROY: DeleteObject(_Font);
    else Result := FALSE;
  end;
end;

BEGIN
  DialogBox(hInstance, MAKEINTRESOURCE(IDD_MAINDLG), 0, @DialogProc);
END

[Reinhard Kern]

Zitat von turboPASCAL:

Hi,

ich möchte in einem Dialogfenster ein Staticcontrol subclassen. Leider wird nicht wie ich
dachte der an das Staticcontrol, ein Statictext, der von mir gesetzte Font verwendet sondern
der Systemfont.
Wenn man SetWindowLong auskommentiert ist der gewünschte Font richtig gesetzt worden.

Habe ich was übersehen ?

Ja (Zitat aus MSDN):
>
GWL_WNDPROC
Sets a new address for the window procedure.

Windows NT/2000/XP: You cannot change this attribute if the window does not belong to the same process as the calling thread.
<

Was du machen möchtest, hat mit Win16 mal funktioniert.

Gruss Reinhard

[Dezipaitor]

Soweit ich das sehe, bleibt alles im eigenen Prozess.


Du könntest auf WM_GETFONTreagieren und dort dein korrektes FONT zurückliefern:

[Luckie]

Setz die Schrift doch im WM_CREATE des Statics.

[turboPASCAL]

WM_CREATE wird leider im Subcass nicht aufgerufen.

Ich habe es erst einmal so gelöst:

Delphi-Quellcode:

var
  OldProc: Pointer;
  Font, olf: HFONT;

function WndProc(hWnd: HWND; uMsg: UINT; wParam, lParam: Integer): LRESULT; stdcall;
var
  ps: PAINTSTRUCT;
  DC: HDC;
  r: trect;
begin
  Result := 0;

  case uMsg of
    WM_PAINT:
      begin
        DC := BeginPaint(hWnd, ps);
        SetBkMode(DC, TRANSPARENT);

        GetClientRect(hWnd, r);
        windows.FrameRect(DC, r, GetStockObject(WHITE_BRUSH));

        olf := SelectObject(DC, Font);
        DrawText(DC, PChar(_MyText), length(_MyText), r,
          DT_SINGLELINE   or DT_NOPREFIX or DT_CENTER or DT_VCENTER);
        SelectObject(DC, olf);

        EndPaint(hWnd, ps);
      end;
    else
      Result := CallWindowProc(OldProc, hWnd, uMsg, wParam, lParam);
  end;
end;

nur hätt ich's gern als echtes Subclassing mit WM_SETFONT. Ich habe es auch mit SetClassLong versucht, jedoch ohne Erfolg.

[Olli]

Wie wäre es denn mit SuperClassing statt Subclassing? Schon mal daran gedacht?

[turboPASCAL]

Zitat von Olli:

Wie wäre es denn mit SuperClassing statt Subclassing? Schon mal daran gedacht?

Nein, habe auch nicht den geringsten Schimmer was das ist.

[Flocke]

Ersetze doch einfach diese Zeile:

Delphi-Quellcode:

// olf := SelectObject(DC, Font);
olf := SelectObject(DC, THandle(SendMessage(hWnd, WM_GETFONT, 0, 0)));

[turboPASCAL]

Zitat von Flocke:

Ersetze doch einfach diese Zeile ...

Nö.

Es geht mir ja darum das ich den Font auch für das Control bereitstellen könnte, zB einem Edit etc.

[Olli]

Zitat von turboPASCAL:

Zitat von Olli:

Wie wäre es denn mit SuperClassing statt Subclassing? Schon mal daran gedacht?

Nein, habe auch nicht den geringsten Schimmer was das ist.

Das Prinzip ist in etwa genauso, aber eben ein kleines bißchen einfacher wenn man es von Anfang an durchzieht. Ach ja, kannst du auch bei dialogbasierten nonVCL-Programmen einsetzen, insofern du sicherstellst, daß du ein "custom control" mit dem von dir für die Superklasse vergeben Namen erstellst.

Das Prinzip:

• Du lädst alle notwendigen DLLs (weil das nicht automatisch passiert), also bspw. die Common Controls. Bei einem Static kannst du diesen Schritt weglassen.
• Dann ermittelst du die Eigenschaften der Klasse die su superclassen willst.
• Dann überschreibst du jene Eigenschaften, die du überschreiben willst.
• Dann registrierst du die neue Klasse im System.

Nähmen wir an die Fensterfunktion der neuen Klasse wäre jetzt nicht in deiner EXE sondern in einer DLL und nähmen wir weiterhin an, daß diese DLL nicht relozierbar ist (wahr für die System-DLLs), dann könntest du innerhalb eines anderen Prozesses auch ein Fenster dieser Fensterklasse erzeugen. Beschränkt wird das wohl nur durch den Desktop oder so (Reichweite von Atoms).

Logischerweise könntest du auch einfach ein Static in der Dialogvorlage erstellen lassen, welches du in WM_INITDIALOG wieder killst, aber zuvor dessen Parameter (Position, Text usw.) übernimmst. Manchmal ist eine solche Vorgehensweise sogar unumgänglich, bspw. wenn du ein einziges Control in einer Anwendung die UNICODE ist als ANSI haben möchstest. Da hilft dann nur das erneute Erstellen mit bekannten Parametern

ACHTUNG: Wenn die in der Dialogvorlage referenzierte Fensterklasse nicht existiert, wird der Dialog nicht erzeugt. Es gibt allerdings ein Flag, um solche Fehler einfach zu ignorieren (DS_NOFAILCREATE).

Nun zum eigentlichen Thema, das Beispiel. Habe mal ganz frech deinen Code als Vorlage genommen. An einigen Stellen noch sichtbar, woanders eher weniger
HINWEIS: Um einen Dialog zu Beenden nehme man bitte EndDialog, nicht DestroyWindow!

Hier erstmal die Dialogvorlage (veranschaulicht!!!, der eigentliche Klassenname ist unten ersichtlich):

Code:

IDD_DIALOG1 DIALOGEX 0, 0, 186, 84
STYLE DS_SETFONT | DS_MODALFRAME | DS_FIXEDSYS | [color=green]/* DS_NOFAILCREATE |*/[/color] WS_POPUP | WS_CAPTION | WS_SYSMENU
CAPTION "Dialog"
FONT 8, "MS Shell Dlg", 400, 0, 0x1
BEGIN
    DEFPUSHBUTTON   "OK",IDOK,129,63,50,14
    LTEXT           "Static",IDC_STC1,7,7,172,8
    CONTROL         [color=red]"Text des Controls"[/color],IDC_CUSTOM1,[color=blue]"Klassenname"[/color],WS_TABSTOP | WS_CHILD | WS_VISIBLE,7,22,172,8
END

Delphi-Quellcode:

program SuperClassBsp;
// [...]
type
  HANDLE = THandle;
  TMyClassDescriptor = record classname: PAnsiChar; parentclass: PAnsiChar; wndproc: TFNWndProc; oldwndproc: TFNWndProc; atom: TAtom; end;
  TMyWndClasses = (wcMyStatic);

// Forward-Deklaration, da es in der Variableninitialisierung benutzt wird!
function MyStaticWndProc(hWnd: HWND; uMsg: UINT; wParam, lParam: Integer): LRESULT; stdcall; forward;

var
  _WndClasses: array[TMyWndClasses] of TMyClassDescriptor =
  (
    (
    classname: 'MeineStaticKlasse';
    parentclass: 'STATIC';
    wndproc: @MyStaticWndProc;
    oldwndproc: nil;
    )
    );

function MyStaticWndProc(hWnd: HWND; uMsg: UINT; wParam, lParam: Integer): LRESULT; stdcall;
// [...]

function DialogProc(hDlg: HWND; uMsg: UINT; wParam, lParam: Integer): BOOL; stdcall;
// [...]

// Generische Funktion um Fensterklassen hinsichtlich ihrer Fensterfunktion zu
// superclassen. _WndClasses muß als globale Variable vorinitialisiert sein!!!
function RegisterMyWindowClasses(): Boolean;
var
  i: TMyWndClasses;
  wc: WNDCLASSEX;
begin
  Result := True;
  for i := Low(_WndClasses) to High(_WndClasses) do
  begin
    ZeroMemory(@wc, sizeof(wc));
    wc.cbSize := sizeof(wc);
    if (GetClassInfoEx(NULL, _WndClasses[i].parentclass, wc)) then
    begin
      // Sichern der alten Fensterfunktion
      _WndClasses[i].oldwndproc := wc.lpfnWndProc;
      // Zuweisen der neuen Fensterfunktion
      wc.lpfnWndProc := _WndClasses[i].wndproc;
      // Neuer Klassenname (so wird er auch in der Dialogvorlage benutzt!)
      wc.lpszClassName := _WndClasses[i].classname;
      // Diese Klasse wurde von uns erzeugt/registriert!
      wc.hInstance := hInstance;
      wc.style := (not CS_GLOBALCLASS) and wc.style;
      // Jetzt sollte alles stimmen (der Rest muß hier schon korrekt sein)
      _WndClasses[i].atom := RegisterClassEx(wc);
//      Writeln('Atom == ', _WndClasses[i].atom, ' (', String(_WndClasses[i].classname), ')');
      // Im Fehlerfall ...
      if (0 = _WndClasses[i].atom) then
      begin
        // ... sicherstellen, daß die Kombination aller Resultate False wird!
        Result := Result and False;
      end;
    end;
  end;
end;

// Generischer Gegenpart zur Funktion RegisterMyWindowClasses().
procedure UnRegisterMyWindowClasses();
var i: TMyWndClasses;
begin
  // ... und abermals gehen wir durch das Array mit den Werten
  for i := Low(_WndClasses) to High(_WndClasses) do
  begin
    if (_WndClasses[i].atom <> 0) then
      if (UnregisterClass(_WndClasses[i].classname, hInstance)) then
      begin
        _WndClasses[i].atom := 0;
      end;
  end;
end;

begin
  if (RegisterMyWindowClasses()) then
  begin
    DialogBox(hInstance, MAKEINTRESOURCE(IDD_DIALOG1), 0, @DialogProc);
  end;
  // Aufräumen in jedem Fall!
  UnRegisterMyWindowClasses();
end.

Zum Thema wo man noch Daten des Fensters/der Fensterklasse abspeichern kann, findet sich hier ein guter Beitrag.