Home » Tutorials » Systemnahe Programmierung » nonVCL

nonVCL

Fensterklassen

Nun zum Eigentlichen – Eigene Fensterklassen basteln 😉

Es geht darum eine Hyperlink-Fensterklasse zu erstellen. Text, der sich, sobald die Maus darüber ist blau färbt und unterstrichen wird – und, der – wenn man draufklickt einen Hyperlink im SHELLEXECUTE()-Stil, also mit dem Standardbrowser öffnet.
Die meisten Delphi-Freunde würden an dieser Stelle die Farbe z.B. eines TLabel im MouseOver Ereignis ändern und im OnClick Ereignis den Hyperlink aufrufen. Ein unschöner Nachteil dessen ist, dass das Control in diesem Fall bei jedem Mal bewegen der Maus neu gezeichnet wird, was zu einem Flackereffekt führt.
Hier zum Ersten die UNIT HLINK (Erklärungen blau im Source):

unit HLink;
interface

const
  AHyperlink = 'AHyperlinkWndClassEx';
  mylink = 'http://www.assarbad.org';
  mymail = 'mailto: Assarbad@ePost.de';
  IDC_LINK1 = 102;
  IDC_LINK2 = 103;

implementation
uses windows,
  messages,
  shellapi;{Für Shellexecute}

const
  HLcursor: DWORD = 0;

var
  inactivefont,
    activefont,
    inactivecolor,
    activecolor: Cardinal;

{Fensterprozedur eines Hyperlink Controls}
function HyperlinkWndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM;
 lParam: LPARAM): LRESULT; stdcall;
var
  prop, DC: DWORD;
  point: TPoint;
  rect: TRect;
  ps: TPaintStruct;
  pc: pchar;

  {Eigentliche Zeichenroutine}
  procedure paint(txtcolor: Cardinal);
  begin
    GetClientRect(hWnd, rect);
    Fillrect(DC, rect, COLOR_WINDOW);
    if txtcolor = inactivecolor then selectobject(dc, inactivefont)
    else selectobject(dc, activefont);
    SetBkMode(DC, TRANSPARENT);
    Settextcolor(DC, txtcolor);
    Getmem(pc, 1000);
    SendMessage(hWnd, WM_GETTEXT, 1000, LongInt(pc));
    GetWindowRect(hWnd, rect);
    ExtTextOut(DC, 0, 0, 2, @rect, pc, lstrlen(pc), NIL);
    Freemem(pc);
  end;

  {Erstellt Font mit variabler Zeichenbreite}
  function varfont(DC: DWORD; size, weight: integer;
    underline: BOOL): DWORD;
  begin
    result := CreateFont(-MulDiv(size, GetDeviceCaps(DC, LOGPIXELSY), 72),
     0, 0, 0, weight, 0, Cardinal(underline), 0, ANSI_CHARSET,
     OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY,
     VARIABLE_PITCH OR FF_ROMAN, 'MS Sans Serif');
  end;

  {Erstellt Font mit fester Zeichenbreite = diktengleich}
  function fixfont(DC: DWORD; size, weight: integer;
    underline: BOOL): DWORD;
  begin
    result := CreateFont(-MulDiv(size, GetDeviceCaps(DC, LOGPIXELSY),
    72), 0, 0, 0, weight, 0, Cardinal(underline), 0, ANSI_CHARSET,
    OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY,
    FIXED_PITCH OR FF_MODERN, 'Courier New');
  end;

begin
  Result := 0;
  case uMsg OF
    WM_CREATE:
      begin
        result := DefWindowProc(hWnd, uMsg, wParam, lParam);
        {Für das Browser-Feeling der Handcursor beim Hyperlink}
        HLcursor := LoadCursor(hInstance, 'HandCursor');
        DC := GetWindowDC(hWnd);
        inactivefont := fixfont(DC, 8, FW_NORMAL, FALSE);
        activefont := fixfont(DC, 8, FW_BOLD, TRUE);
        ReleaseDC(hWnd, DC);
        inactivecolor := rgb($0, $0, $0);
        activecolor := rgb($0, $0, $FF);
        SendMessage(hWnd, WM_CAPTURECHANGED, 0, 0);
      end;
    WM_RBUTTONUP,
      WM_LBUTTONUP:
      begin
        {Hier der Beweis, auch API Fenster können Properties haben!
        Gell, Nico 😉 ...}
        prop := getprop(hwnd, 'Link');
        IF prop <> 0 THEN shellexecute(0, 'open', pchar(prop), '',
        '', SW_SHOWNORMAL);
      end;
    WM_CAPTURECHANGED,
      WM_MOUSEMOVE:
      begin
        GetCursorPos(point);
        GetWindowRect(hwnd, rect);
        {Gegen das unschöne Flackern fangen wir den Cursor ein und
        geben ihn beim Verlassen frei}
        if PtInRect(rect, point) then begin
          if GetCapture <> hWnd then begin
            SetCapture(hWnd);
            SetCursor(HLcursor);
            SendMessage(hWnd, WM_PAINT, activecolor, -1);
          END;
        end else begin
          ReleaseCapture;
          SendMessage(hWnd, WM_PAINT, inactivecolor, -1);
        end;
      end;
    WM_PAINT:
      begin
        case lParam of
          -1: begin
              DC := GetWindowDC(hWnd);
              paint(wParam);
              ReleaseDC(hWnd, DC);
            end;
        else begin
            DC := BeginPaint(hWnd, ps);
            paint(wParam);
            EndPaint(hWnd, ps);
          end;
        end;
      end;
  else result := DefWindowProc(hWnd, uMsg, wParam, lParam);
  end;
end;

{Initialisierung - siehe oben}
procedure initacomctl;
var
  wc: TWndClassEx;
begin
  wc.style := CS_HREDRAW OR CS_VREDRAW OR CS_GLOBALCLASS;
  wc.cbSize := sizeof(TWNDCLASSEX);
  wc.lpfnWndProc := @HyperlinkWndProc;
  wc.cbClsExtra := 0;
  wc.cbWndExtra := 0;
  wc.hInstance := hInstance;
  wc.hbrBackground := COLOR_WINDOW;
  wc.lpszMenuName := NIL;
  wc.lpszClassName := AHyperlink;
  wc.hIcon := 0;
  wc.hIconSm := 0;
  wc.hCursor := 0;
  RegisterClassEx(wc);
end;


{Initialisierung der UNIT, somit steht die Fensterklasse gleich
zum Anfang zur Verfügung.}

initialization
  initacomctl;
end.

Zum Verständnis dieser Routinen empfehle ich das MS Platform SDK für Win32. Damit kann man alle Funktionen in einer übersichtlichen Hilfe nachvollziehen.
Interessant mag sein, dass ein jedes auch noch so kleines Control unter Windows ein eigenes Fensterhandle hat und somit ein eigenes vollwertiges Fenster ist! An dieser Stelle sei zu bemerken, dass Windows 95 nicht mal die 16 Bit-Grenze ausschöpfen kann. Bei rund 16000 Handles ist Schluss – schöne 32-bit-Welt.
So sieht das Resource Script dazu aus (man beachte die Klassennamen!):

LANGUAGE LANG_NEUTRAL, SUBLANG_NEUTRAL

100 DIALOGEX 6, 18, 264, 85
STYLE DS_MODALFRAME | DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION |
WS_SYSMENU
EXSTYLE WS_EX_TOOLWINDOW
CAPTION „HLinkTest“
FONT 8, „Arial“
BEGIN
CONTROL „Schreib doch mal an Assarbad ;)“, 102,
„AHyperlinkWndClassEx“, WS_TABSTOP,6, 12, 252, 12
CONTROL „Die tolle Homepage von Assarbad findest du HIER“, 101,
„AHyperlinkWndClassEx“, WS_TABSTOP,6, 43, 252, 12
PUSHBUTTON „OK“, IDOK, 61, 65, 40, 14
PUSHBUTTON „Abrechen“, IDCANCEL, 160, 65, 40, 14
END

Erzeugt man nun einen solchen Dialog, muss der Klassenname vorher registriert sein – deshalb auch die UNIT Initialisierung.
Das Ganze sieht wie folgt aus:

program HLinkTest;
uses windows,
  messages,
  HLink;

{$WARNINGS OFF}
{$R main.res}

var
  hdlg: DWORD = 0;

function dlgfunc(hwnd: hwnd; umsg: dword; wparam: wparam;
 lparam: lparam): bool; stdcall;
begin
  result := true;
  case umsg of
    WM_INITDIALOG:
      begin
{
Interessant hier, die Nutzbarmachung von Properties. Die Property "Link"
enthält den auszuführenden Teil.
}
        setprop(getdlgitem(hwnd, 101), 'Link', DWORD(pchar(mylink)));
        setprop(getdlgitem(hwnd, 102), 'Link', DWORD(pchar(mymail)));
      end;
    WM_CLOSE:
      EndDialog(hWnd, 0);
    WM_DESTROY:
      begin
        PostQuitMessage(0);
      end;
    WM_COMMAND:
      if hiword(wparam) = BN_CLICKED then begin
        case loword(wparam) of
          IDCANCEL,
          IDOK:
            sendmessage(hwnd,WM_CLOSE,0,0);
        end;
      end;
  else result := false;
  end;
end;

begin
  hdlg := DialogBoxParam(HInstance, MAKEINTRESOURCE(100), 0, @DlgFunc, 0);
end.

Download des Beispiels (15 KB)