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)