1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
unit WinAllocation;
// FPC misses AllocateHWnd and DeallocateHWnd which is used by several
// libraries such as Midi... or DirWatch.
// Since FPC 2.2.2 there are dummies in Classes that just raise RunTime exceptions.
// To avoid those exceptions, include this unit AFTER Classes.
// Maybe the dummies will be replaced by functional routines in the future.WinAllocation
//
// THESE FUNCTIONS ARE ONLY FOR COMPATIBILITY WITH SOME EXTERNAL WIN32 LIBS.
// DO NOT USE THEM IN USDX CODE.
//
interface
uses
Classes,
Windows;
function AllocateHWnd(Method: TWndMethod): HWND;
procedure DeallocateHWnd(hWnd: HWND);
implementation
function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Msg: TMessage;
MethodPtr: ^TWndMethod;
begin
FillChar(Msg, SizeOf(Msg), 0);
Msg.msg := uMsg;
Msg.wParam := wParam;
Msg.lParam := lParam;
MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA));
if Assigned(MethodPtr) then
MethodPtr^(Msg);
Result := DefWindowProc(hwnd, uMsg, wParam, lParam);
end;
function AllocateHWnd(Method: TWndMethod): HWND;
var
ClassExists: Boolean;
WndClass, OldClass: TWndClass;
MethodPtr: ^TMethod;
begin
Result := 0;
// setup class-info
FillChar(WndClass, SizeOf(TWndClass), 0);
WndClass.hInstance := HInstance;
// Important: do not enable AllocateHWndCallback before the msg-handler method is assigned,
// otherwise race-conditions might occur
WndClass.lpfnWndProc := @DefWindowProc;
WndClass.lpszClassName:= 'USDXUtilWindowClass';
// check if class is already registered
ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass);
// create window-class shared by all windows created by AllocateHWnd()
if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then
begin
if ClassExists then
UnregisterClass(WndClass.lpszClassName, HInstance);
if (RegisterClass(WndClass) = 0) then
Exit;
end;
// create window
Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '',
DWORD(WS_POPUP), 0, 0, 0, 0, 0, 0, HInstance, nil);
if (Result = 0) then
Exit;
// assign individual callback procedure to the window
if Assigned(Method) then
begin
// TMethod contains two pointers but we can pass just one as USERDATA
GetMem(MethodPtr, SizeOf(TMethod));
MethodPtr^ := TMethod(Method);
SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr));
end;
// now enable AllocateHWndCallback for this window
SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback));
end;
procedure DeallocateHWnd(hWnd: HWND);
var
MethodPtr: ^TMethod;
begin
if (hWnd <> 0) then
begin
MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA));
DestroyWindow(hWnd);
if Assigned(MethodPtr) then
FreeMem(MethodPtr);
end;
end;
end.
|
