1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Abstract:
22 Show a window before the LCL is initialized.
23 }
24 unit raw_window;
25
26 {$mode objfpc}{$H+}
27
28 interface
29
30 {$IFDEF Windows}
31 {$IFDEF HEAPTRC_WINDOW}
32 {$IF FPC_FULLVERSION>=20701}
33 uses
34 SysUtils, Windows, Messages;
35
36 procedure ShowWindow(AStr : String);
37 {$ENDIF}
38 {$ENDIF}
39 {$ENDIF}
40
41 implementation
42
43 {$IFDEF Windows}
44 {$IFDEF HEAPTRC_WINDOW}
45 {$IF FPC_FULLVERSION>=20701}
46 Var
47 WndHandle,
48 ButtonHandle,
49 EditHandle : HWND;
50 OldSubProc : WNDPROC;
51
issetnull52 function isset(value: dword; bit: byte): boolean;
53 begin
54 result := value and (1 shl pred(bit)) <> 0;
55 end;
56
WindowWndProcnull57 function WindowWndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam) : LRESULT; stdcall;
58 Var
59 ControlCode, ControlID : Word;
60 begin
61 Result := 0;
62 Case uMsg Of
63 WM_DESTROY : PostQuitMessage(0);
64 WM_COMMAND : Begin
65 ControlCode := HiWord(wParam);
66 ControlID := LoWord(wParam);
67 Case ControlCode Of
68 BN_CLICKED : If lParam = ButtonHandle Then
69 PostMessage(WndHandle, WM_CLOSE, 0, 0);
70 end;
71 end;
72 WM_SETFOCUS: SetFocus(EditHandle);
73 Else
74 Result := Windows.DefWindowProc(ahwnd, uMsg, wParam, lParam);
75 End;
76
77 end;
78
EditSubProcnull79 function EditSubProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam) : LRESULT; stdcall;
80 Var
81 AKeyboardState : TKeyboardState;
82 Begin
83 Case uMsg of
84 WM_KEYDOWN : Begin
85 GetKeyboardState(AKeyboardState);
86 If isset(AKeyboardState[VK_CONTROL], 8) And isset(AKeyboardState[VK_A], 8) Then Begin
87 SendMessage(EditHandle, EM_SETSEL, 0, -1);
88 Exit(0);
89 end;
90 If isset(AKeyboardState[VK_CONTROL], 8) And isset(AKeyboardState[VK_C], 8) Then Begin
91 PostMessage(EditHandle, WM_COPY, 0, 0);
92 Exit(0);
93 End;
94 If isset(AKeyboardState[VK_RETURN], 8) Or isset(AKeyboardState[VK_ESCAPE], 8) Then Begin
95 PostMessage(ButtonHandle, BM_CLICK, 0, 0);
96 Exit(0);
97 end;
98 end;
99 End;
100 Result := CallWindowProc(OldSubProc, Ahwnd, uMsg, wParam, lParam);
101 end;
102
103
104 procedure ShowWindow(AStr : String);
105 Var
106 A_Atom : TAtom = 0;
107 WndClass : TWndClass;
108 Msg: TMsg;
109 ScreenWidth, ScreenHeight, MiddleX, MiddleY : LongInt;
110 Begin
111 FillChar(WndClass, SizeOf(TWndClass), 0);
112
113 ScreenWidth := GetSystemMetrics(SM_CXSCREEN);
114 ScreenHeight := GetSystemMetrics(SM_CYSCREEN);
115
116 MiddleX := (ScreenWidth - 500) Div 2;
117 MiddleY := (ScreenHeight - 500) div 2;
118
119 WndClass.lpszClassName:= 'HEAPTRACE_CLASS';
120 WndClass.lpfnWndProc := @WindowWndProc;
121
122 WndClass.hInstance := hInstance;
123 WndClass.hbrBackground:= 1;
124 WndClass.style := CS_HREDRAW or CS_VREDRAW;
125 WndClass.hCursor := LoadCursor(0, IDC_ARROW);
126
127 A_Atom := RegisterClass(WndClass);
128
129 WndHandle := CreateWindow(
130 WndClass.lpszClassName , // lpClassName, optional
131 'Heaptrace results', // lpWindowName, optional
132 WS_OVERLAPPEDWINDOW or WS_VISIBLE , // dwStyle
133 MiddleX, // x
134 MiddleY, // y
135 500, // nWidth
136 500, // nHeight
137 0, // hWndParent
138 0, // hMenu
139 WndClass.hInstance, // hInstance
140 nil // lpParam
141 );
142
143 // Button control
144
145 ButtonHandle := CreateWindow(
146 'BUTTON' , // lpClassName, optional
147 'OK', // lpWindowName, optional
148 WS_TABSTOP or WS_VISIBLE or WS_CHILD or BS_DEFPUSHBUTTON , // dwStyle
149 400, // x
150 400, // y
151 50, // nWidth
152 50, // nHeight
153 WndHandle, // hWndParent
154 0, // hMenu
155 WndClass.hInstance, // hInstance
156 nil // lpParam
157 );
158
159 // Edit control
160
161 EditHandle := CreateWindow(
162 'EDIT' , // lpClassName, optional
163 NIL, // lpWindowName, optional
164 WS_CHILD or WS_VISIBLE or WS_VSCROLL or WS_HSCROLL or WS_BORDER or ES_LEFT or ES_MULTILINE or ES_AUTOHSCROLL or ES_AUTOVSCROLL or ES_READONLY, // dwStyle
165 10, // x
166 10, // y
167 450, // nWidth
168 370, // nHeight
169 WndHandle, // hWndParent
170 0, // hMenu
171 WndClass.hInstance, // hInstance
172 nil // lpParam
173 );
174
175 SetWindowText(EditHandle, PChar(UTF8ToAnsi(AStr)));
176
177 OldSubProc := Windows.WNDPROC(GetWindowLongPtr(EditHandle, GWL_WNDPROC));
178 SetWindowLongPtr(EditHandle, GWL_WNDPROC, PtrUint(@EditSubProc));
179
180 BringWindowToTop(WndHandle);
181 SetFocus(EditHandle);
182
183 while GetMessage(Msg,0,0,0) do
184 DispatchMessage(Msg);
185
186 DestroyWindow(ButtonHandle);
187 DestroyWindow(EditHandle);
188 DestroyWindow(WndHandle);
189
190 UnregisterClass(WndClass.lpszClassName, WndClass.hInstance);
191 end;
192 {$ENDIF}
193 {$ENDIF}
194 {$ENDIF}
195
196 end.
197
198