1 { ------------------------------
2 winproc.pp
3 ------------------------------
4
5 Misc types and procedures for LCL-CustomDrawn-Windows
6
7 *****************************************************************************
8 This file is part of the Lazarus Component Library (LCL)
9
10 See the file COPYING.modifiedLGPL.txt, included in this distribution,
11 for details about the license.
12 *****************************************************************************
13 }
14
15 unit customdrawn_winproc;
16
17 {$mode objfpc}{$H+}
18
19 interface
20
21 uses
22 Windows, CTypes, Classes, SysUtils,
23 // LCL
24 LCLType, Interfacebase, LMessages, lclintf, LCLMessageGlue, LCLProc,
25 Controls, Forms, graphtype, Menus, IntfGraphics, lazcanvas,
26 //
27 customdrawnproc;
28
29 type
30 MCHITTESTINFO = record
31 cbSize: UINT;
32 pt : TPoint;
33 uHit : UINT; // out param
34 st : SYSTEMTIME;
35 end;
36 TMCMHitTestInfo = MCHITTESTINFO;
37 PMCMHitTestInfo = ^TMCMHitTestInfo;
38
39 // Window information snapshot
40 tagWINDOWINFO = record
41 cbSize: DWORD;
42 rcWindow: TRect;
43 rcClient: TRect;
44 dwStyle: DWORD;
45 dwExStyle: DWORD;
46 dwWindowStatus: DWORD;
47 cxWindowBorders: UINT;
48 cyWindowBorders: UINT;
49 atomWindowType: ATOM;
50 wCreatorVersion: WORD;
51 end;
52 PTAGWINDOWINFO = ^tagWINDOWINFO;
53
54 type
55 { lazarus win32 Interface definition for additional timer data needed to find the callback}
56 PWinCETimerInfo = ^TWinCETimerinfo;
57 TWinCETimerInfo = record
58 TimerID: UINT_PTR; // the windows timer ID for this timer
tonull59 TimerFunc: TWSTimerProc; // owner function to handle timer
60 end;
61
62 {$ifdef WinCE}
EnumDisplayMonitorsnull63 function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; cdecl; external KernelDLL name 'EnumDisplayMonitors';
GetMonitorInfoWnull64 function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; cdecl; external KernelDLL name 'GetMonitorInfo';
MonitorFromWindownull65 function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; cdecl; external KernelDLL name 'MonitorFromWindow';
MonitorFromRectnull66 function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromRect';
MonitorFromPointnull67 function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromPoint';
68 {$else}
EnumDisplayMonitorsnull69 function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; stdcall; external 'user32.dll' name 'EnumDisplayMonitors';
GetMonitorInfoWnull70 function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; stdcall; external 'user32.dll' name 'GetMonitorInfoW';
MonitorFromWindownull71 function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromWindow';
MonitorFromRectnull72 function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromRect';
MonitorFromPointnull73 function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromPoint';
74 // from win32extra.pp
GetWindowInfonull75 function GetWindowInfo(hwnd: HWND; pwi: PTAGWINDOWINFO): BOOL; stdcall; external 'user32.dll' name 'GetWindowInfo';
76 {$endif}
77
78 type
79 TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged);
80
81 PProcessEvent = ^TProcessEvent;
82 TProcessEvent = record
83 Handle: THandle;
84 Handler: PEventHandler;
85 UserData: PtrInt;
86 OnEvent: TChildExitEvent;
87 end;
88
89 var
90 // FTimerData contains the currently running timers
91 FTimerData : TList; // list of PWin32Timerinfo
92
93 MouseDownTime: dword;
94 MouseDownPos: TPoint;
95 MouseDownWindow: HWND = 0;
96 MouseDownFocusWindow: HWND;
97 MouseDownFocusStatus: TMouseDownFocusStatus = mfNone;
98 ComboBoxHandleSizeWindow: HWND = 0;//just do not know the use yet
99 IgnoreNextCharWindow: HWND = 0; // ignore next WM_(SYS)CHAR message
100 OnClipBoardRequest: TClipboardRequestEvent = nil;
101
102 type
103 TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown);
104
105 TWindowInfo = class(TCDForm)
106 Overlay: HWND; // overlay, transparent window on top, used by designer
107 //PopupMenu: TPopupMenu;
108 DefWndProc: WNDPROC;
109 ParentPanel: HWND; // if non-zero, is the tabsheet window, for the pagecontrol hack
110 List: TStrings;
111 StayOnTopList: TList; // a list of windows that were normalized when showing modal
112 MaxLength: dword;
113 MouseX, MouseY: word; // noticing spurious WM_MOUSEMOVE messages
114 // CD additions
115 Bitmap: HBITMAP;
116 BitmapWidth: integer;
117 BitmapHeight: integer;
118 BitmapDC, DCBitmapOld: HDC;
119 end;
120
121 PStayOnTopWindowsInfo = ^TStayOnTopWindowsInfo;
122 TStayOnTopWindowsInfo = record
123 AppHandle: HWND;
124 SystemTopAlso: Boolean;
125 StayOnTopList: TList;
126 end;
127
128 TWindowsVersion = (
129 wvUnknown,
130 //
131 wince_1,
132 wince_2,
133 wince_3,
134 wince_4,
135 wince_5,
136 wince_6,
137 wince_6_1,
138 wince_6_5,
139 wince_7,
140 wince_other,
141 //
142 wv95,
143 wvNT4,
144 wv98,
145 wvMe,
146 wv2000,
147 wvXP,
148 wvServer2003,
149 //wvServer2003R2, // has the same major/minor as wvServer2003
150 wvVista,
151 //wvServer2008, // has the same major/minor as wvVista
152 wv7,
153 wv8,
154 wvLater
155 );
156
WM_To_Stringnull157 function WM_To_String(WM_Message: Integer): string;
WindowPosFlagsToStringnull158 function WindowPosFlagsToString(Flags: UINT): string;
ObjectToHWNDnull159 function ObjectToHWND(Const AObject: TObject): HWND;
160
BytesPerLinenull161 function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
CreateDIBSectionFromDescriptionnull162 function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
163 procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
164 procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
WinProc_RawImage_FromBitmapnull165 function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
WinProc_RawImage_CreateBitmapsnull166 function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
167
168 {$ifndef WinCE}
GetBitmapOrdernull169 function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP):TRawImageLineOrder;
170 {$endif}
GetBitmapBytesnull171 function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
IsAlphaBitmapnull172 function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
IsAlphaDCnull173 function IsAlphaDC(ADC: HDC): Boolean;
174
GetLastErrorTextnull175 function GetLastErrorText(AErrorCode: Cardinal): WideString;
176
LCLControlSizeNeedsUpdatenull177 function LCLControlSizeNeedsUpdate(Sender: TWinControl;
178 SendSizeMsgOnDiff: boolean): boolean;
179
GetLCLClientBoundsOffsetnull180 function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
GetLCLClientBoundsOffsetnull181 function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean;
182 procedure LCLBoundsToWin32Bounds(Sender: TObject; var Left, Top: Integer);
183 procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
184 procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
185
GetWindowInfonull186 function GetWindowInfo(AWindow: HWND): TWindowInfo;
187
188 procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
BorderStyleToWinAPIFlagsnull189 function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
BorderStyleToWinAPIFlagsExnull190 function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
191
GetFileVersionnull192 function GetFileVersion(FileName: string): dword;
193
194 procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
195 procedure RestoreStayOnTopFlags(AppHandle: HWND);
196
197 procedure AddToChangedMenus(Window: HWnd);
198 procedure RedrawMenus;
MeasureTextnull199 function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
GetControlTextnull200 function GetControlText(AHandle: HWND): string;
201
202 { String functions that may be moved to the RTL in the future }
203 procedure WideStrCopy(Dest, Src: PWideChar);
WideStrLCopynull204 function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
WideStrCmpnull205 function WideStrCmp(W1, W2: PWideChar): Integer;
206
207 { Automatic detection of platform }
GetWinCEPlatformnull208 function GetWinCEPlatform: TApplicationType;
IsHiResModenull209 function IsHiResMode: Boolean;
210 procedure UpdateWindowsVersion;
211
212 var
213 DefaultWindowInfo: TWindowInfo;
214 WindowInfoAtom: ATOM;
215 OverwriteCheck: Integer = 0;
216 ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn
217
218 WindowsVersion: TWindowsVersion = wvUnknown;
219
220 const
221 ClsName: array[0..6] of WideChar = ('W', 'i', 'n', 'd', 'o', 'w', #0);
222 ClsHintName: array[0..10] of WideChar = ('H', 'i', 'n', 't', 'W', 'i', 'n', 'd', 'o', 'w', #0);
223
224 implementation
225
226 uses customdrawnint;
227
228 var
229 InRemoveStayOnTopFlags: Integer = 0;
230
231 {------------------------------------------------------------------------------
232 Function: WM_To_String
233 Params: WM_Message - a WinDows message
234 Returns: A WinDows-message name
235
236 Converts a winDows message identIfier to a string
237 ------------------------------------------------------------------------------}
WM_To_Stringnull238 function WM_To_String(WM_Message: Integer): string;
239 Begin
240 Case WM_Message of
241 $0000: Result := 'WM_NULL';
242 $0001: Result := 'WM_CREATE';
243 $0002: Result := 'WM_DESTROY';
244 $0003: Result := 'WM_MOVE';
245 $0005: Result := 'WM_SIZE';
246 $0006: Result := 'WM_ACTIVATE';
247 $0007: Result := 'WM_SETFOCUS';
248 $0008: Result := 'WM_KILLFOCUS';
249 $000A: Result := 'WM_ENABLE';
250 $000B: Result := 'WM_SETREDRAW';
251 $000C: Result := 'WM_SETTEXT';
252 $000D: Result := 'WM_GETTEXT';
253 $000E: Result := 'WM_GETTEXTLENGTH';
254 $000F: Result := 'WM_PAINT';
255 $0010: Result := 'WM_CLOSE';
256 $0011: Result := 'WM_QUERYENDSESSION';
257 $0012: Result := 'WM_QUIT';
258 $0013: Result := 'WM_QUERYOPEN';
259 $0014: Result := 'WM_ERASEBKGND';
260 $0015: Result := 'WM_SYSCOLORCHANGE';
261 $0016: Result := 'WM_EndSESSION';
262 $0017: Result := 'WM_SYSTEMERROR';
263 $0018: Result := 'WM_SHOWWINDOW';
264 $0019: Result := 'WM_CTLCOLOR';
265 $001A: Result := 'WM_WININICHANGE or WM_SETTINGCHANGE';
266 $001B: Result := 'WM_DEVMODECHANGE';
267 $001C: Result := 'WM_ACTIVATEAPP';
268 $001D: Result := 'WM_FONTCHANGE';
269 $001E: Result := 'WM_TIMECHANGE';
270 $001F: Result := 'WM_CANCELMODE';
271 $0020: Result := 'WM_SETCURSOR';
272 $0021: Result := 'WM_MOUSEACTIVATE';
273 $0022: Result := 'WM_CHILDACTIVATE';
274 $0023: Result := 'WM_QUEUESYNC';
275 $0024: Result := 'WM_GETMINMAXINFO';
276 $0026: Result := 'WM_PAINTICON';
277 $0027: Result := 'WM_ICONERASEBKGND';
278 $0028: Result := 'WM_NEXTDLGCTL';
279 $002A: Result := 'WM_SPOOLERSTATUS';
280 $002B: Result := 'WM_DRAWITEM';
281 $002C: Result := 'WM_MEASUREITEM';
282 $002D: Result := 'WM_DELETEITEM';
283 $002E: Result := 'WM_VKEYTOITEM';
284 $002F: Result := 'WM_CHARTOITEM';
285 $0030: Result := 'WM_SETFONT';
286 $0031: Result := 'WM_GETFONT';
287 $0032: Result := 'WM_SETHOTKEY';
288 $0033: Result := 'WM_GETHOTKEY';
289 $0037: Result := 'WM_QUERYDRAGICON';
290 $0039: Result := 'WM_COMPAREITEM';
291 $003D: Result := 'WM_GETOBJECT';
292 $0041: Result := 'WM_COMPACTING';
293 $0044: Result := 'WM_COMMNOTIFY { obsolete in Win32}';
294 $0046: Result := 'WM_WINDOWPOSCHANGING';
295 $0047: Result := 'WM_WINDOWPOSCHANGED';
296 $0048: Result := 'WM_POWER';
297 $004A: Result := 'WM_COPYDATA';
298 $004B: Result := 'WM_CANCELJOURNAL';
299 $004E: Result := 'WM_NOTIFY';
300 $0050: Result := 'WM_INPUTLANGCHANGEREQUEST';
301 $0051: Result := 'WM_INPUTLANGCHANGE';
302 $0052: Result := 'WM_TCARD';
303 $0053: Result := 'WM_HELP';
304 $0054: Result := 'WM_USERCHANGED';
305 $0055: Result := 'WM_NOTIFYFORMAT';
306 $007B: Result := 'WM_CONTEXTMENU';
307 $007C: Result := 'WM_STYLECHANGING';
308 $007D: Result := 'WM_STYLECHANGED';
309 $007E: Result := 'WM_DISPLAYCHANGE';
310 $007F: Result := 'WM_GETICON';
311 $0080: Result := 'WM_SETICON';
312 $0081: Result := 'WM_NCCREATE';
313 $0082: Result := 'WM_NCDESTROY';
314 $0083: Result := 'WM_NCCALCSIZE';
315 $0084: Result := 'WM_NCHITTEST';
316 $0085: Result := 'WM_NCPAINT';
317 $0086: Result := 'WM_NCACTIVATE';
318 $0087: Result := 'WM_GETDLGCODE';
319 $00A0: Result := 'WM_NCMOUSEMOVE';
320 $00A1: Result := 'WM_NCLBUTTONDOWN';
321 $00A2: Result := 'WM_NCLBUTTONUP';
322 $00A3: Result := 'WM_NCLBUTTONDBLCLK';
323 $00A4: Result := 'WM_NCRBUTTONDOWN';
324 $00A5: Result := 'WM_NCRBUTTONUP';
325 $00A6: Result := 'WM_NCRBUTTONDBLCLK';
326 $00A7: Result := 'WM_NCMBUTTONDOWN';
327 $00A8: Result := 'WM_NCMBUTTONUP';
328 $00A9: Result := 'WM_NCMBUTTONDBLCLK';
329 $0100: Result := 'WM_KEYFIRST or WM_KEYDOWN';
330 $0101: Result := 'WM_KEYUP';
331 $0102: Result := 'WM_CHAR';
332 $0103: Result := 'WM_DEADCHAR';
333 $0104: Result := 'WM_SYSKEYDOWN';
334 $0105: Result := 'WM_SYSKEYUP';
335 $0106: Result := 'WM_SYSCHAR';
336 $0107: Result := 'WM_SYSDEADCHAR';
337 $0108: Result := 'WM_KEYLAST';
338 $010D: Result := 'WM_IME_STARTCOMPOSITION';
339 $010E: Result := 'WM_IME_ENDCOMPOSITION';
340 $010F: Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST';
341 $0110: Result := 'WM_INITDIALOG';
342 $0111: Result := 'WM_COMMAND';
343 $0112: Result := 'WM_SYSCOMMAND';
344 $0113: Result := 'WM_TIMER';
345 $0114: Result := 'WM_HSCROLL';
346 $0115: Result := 'WM_VSCROLL';
347 $0116: Result := 'WM_INITMENU';
348 $0117: Result := 'WM_INITMENUPOPUP';
349 $011F: Result := 'WM_MENUSELECT';
350 $0120: Result := 'WM_MENUCHAR';
351 $0121: Result := 'WM_ENTERIDLE';
352 $0122: Result := 'WM_MENURBUTTONUP';
353 $0123: Result := 'WM_MENUDRAG';
354 $0124: Result := 'WM_MENUGETOBJECT';
355 $0125: Result := 'WM_UNINITMENUPOPUP';
356 $0126: Result := 'WM_MENUCOMMAND';
357 $0132: Result := 'WM_CTLCOLORMSGBOX';
358 $0133: Result := 'WM_CTLCOLOREDIT';
359 $0134: Result := 'WM_CTLCOLORLISTBOX';
360 $0135: Result := 'WM_CTLCOLORBTN';
361 $0136: Result := 'WM_CTLCOLORDLG';
362 $0137: Result := 'WM_CTLCOLORSCROLLBAR';
363 $0138: Result := 'WM_CTLCOLORSTATIC';
364 $0200: Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE';
365 $0201: Result := 'WM_LBUTTONDOWN';
366 $0202: Result := 'WM_LBUTTONUP';
367 $0203: Result := 'WM_LBUTTONDBLCLK';
368 $0204: Result := 'WM_RBUTTONDOWN';
369 $0205: Result := 'WM_RBUTTONUP';
370 $0206: Result := 'WM_RBUTTONDBLCLK';
371 $0207: Result := 'WM_MBUTTONDOWN';
372 $0208: Result := 'WM_MBUTTONUP';
373 $0209: Result := 'WM_MBUTTONDBLCLK';
374 $020A: Result := 'WM_MOUSEWHEEL or WM_MOUSELAST';
375 $0210: Result := 'WM_PARENTNOTIFY';
376 $0211: Result := 'WM_ENTERMENULOOP';
377 $0212: Result := 'WM_EXITMENULOOP';
378 $0213: Result := 'WM_NEXTMENU';
379 $0214: Result := 'WM_SIZING';
380 $0215: Result := 'WM_CAPTURECHANGED';
381 $0216: Result := 'WM_MOVING';
382 $0218: Result := 'WM_POWERBROADCAST';
383 $0219: Result := 'WM_DEVICECHANGE';
384 $0220: Result := 'WM_MDICREATE';
385 $0221: Result := 'WM_MDIDESTROY';
386 $0222: Result := 'WM_MDIACTIVATE';
387 $0223: Result := 'WM_MDIRESTORE';
388 $0224: Result := 'WM_MDINEXT';
389 $0225: Result := 'WM_MDIMAXIMIZE';
390 $0226: Result := 'WM_MDITILE';
391 $0227: Result := 'WM_MDICASCADE';
392 $0228: Result := 'WM_MDIICONARRANGE';
393 $0229: Result := 'WM_MDIGETACTIVE';
394 $0230: Result := 'WM_MDISETMENU';
395 $0231: Result := 'WM_ENTERSIZEMOVE';
396 $0232: Result := 'WM_EXITSIZEMOVE';
397 $0233: Result := 'WM_DROPFILES';
398 $0234: Result := 'WM_MDIREFRESHMENU';
399 $0281: Result := 'WM_IME_SETCONTEXT';
400 $0282: Result := 'WM_IME_NOTIFY';
401 $0283: Result := 'WM_IME_CONTROL';
402 $0284: Result := 'WM_IME_COMPOSITIONFULL';
403 $0285: Result := 'WM_IME_SELECT';
404 $0286: Result := 'WM_IME_CHAR';
405 $0288: Result := 'WM_IME_REQUEST';
406 $0290: Result := 'WM_IME_KEYDOWN';
407 $0291: Result := 'WM_IME_KEYUP';
408 $02A1: Result := 'WM_MOUSEHOVER';
409 $02A3: Result := 'WM_MOUSELEAVE';
410 $0300: Result := 'WM_CUT';
411 $0301: Result := 'WM_COPY';
412 $0302: Result := 'WM_PASTE';
413 $0303: Result := 'WM_CLEAR';
414 $0304: Result := 'WM_UNDO';
415 $0305: Result := 'WM_RENDERFORMAT';
416 $0306: Result := 'WM_RENDERALLFORMATS';
417 $0307: Result := 'WM_DESTROYCLIPBOARD';
418 $0308: Result := 'WM_DRAWCLIPBOARD';
419 $0309: Result := 'WM_PAINTCLIPBOARD';
420 $030A: Result := 'WM_VSCROLLCLIPBOARD';
421 $030B: Result := 'WM_SIZECLIPBOARD';
422 $030C: Result := 'WM_ASKCBFORMATNAME';
423 $030D: Result := 'WM_CHANGECBCHAIN';
424 $030E: Result := 'WM_HSCROLLCLIPBOARD';
425 $030F: Result := 'WM_QUERYNEWPALETTE';
426 $0310: Result := 'WM_PALETTEISCHANGING';
427 $0311: Result := 'WM_PALETTECHANGED';
428 $0312: Result := 'WM_HOTKEY';
429 $0317: Result := 'WM_PRINT';
430 $0318: Result := 'WM_PRINTCLIENT';
431 $0358: Result := 'WM_HANDHELDFIRST';
432 $035F: Result := 'WM_HANDHELDLAST';
433 $0380: Result := 'WM_PENWINFIRST';
434 $038F: Result := 'WM_PENWINLAST';
435 $0390: Result := 'WM_COALESCE_FIRST';
436 $039F: Result := 'WM_COALESCE_LAST';
437 $03E0: Result := 'WM_DDE_FIRST or WM_DDE_INITIATE';
438 $03E1: Result := 'WM_DDE_TERMINATE';
439 $03E2: Result := 'WM_DDE_ADVISE';
440 $03E3: Result := 'WM_DDE_UNADVISE';
441 $03E4: Result := 'WM_DDE_ACK';
442 $03E5: Result := 'WM_DDE_DATA';
443 $03E6: Result := 'WM_DDE_REQUEST';
444 $03E7: Result := 'WM_DDE_POKE';
445 $03E8: Result := 'WM_DDE_EXECUTE or WM_DDE_LAST';
446 $0400: Result := 'WM_USER';
447 $8000: Result := 'WM_APP';
448 Else
449 Result := 'Unknown(' + IntToStr(WM_Message) + ')';
450 End; {Case}
451 End;
452
WindowPosFlagsToStringnull453 function WindowPosFlagsToString(Flags: UINT): string;
454 var
455 FlagsStr: string;
456 begin
457 FlagsStr := '';
458 if (Flags and SWP_DRAWFRAME) <> 0 then
459 FlagsStr := FlagsStr + '|SWP_DRAWFRAME';
460 if (Flags and SWP_HIDEWINDOW) <> 0 then
461 FlagsStr := FlagsStr + '|SWP_HIDEWINDOW';
462 if (Flags and SWP_NOACTIVATE) <> 0 then
463 FlagsStr := FlagsStr + '|SWP_NOACTIVATE';
464 if (Flags and SWP_NOCOPYBITS) <> 0 then
465 FlagsStr := FlagsStr + '|SWP_NOCOPYBITS';
466 if (Flags and SWP_NOMOVE) <> 0 then
467 FlagsStr := FlagsStr + '|SWP_NOMOVE';
468 if (Flags and SWP_NOOWNERZORDER) <> 0 then
469 FlagsStr := FlagsStr + '|SWP_NOOWNERZORDER';
470 if (Flags and SWP_NOREDRAW) <> 0 then
471 FlagsStr := FlagsStr + '|SWP_NOREDRAW';
472 if (Flags and SWP_NOSENDCHANGING) <> 0 then
473 FlagsStr := FlagsStr + '|SWP_NOSENDCHANGING';
474 if (Flags and SWP_NOSIZE) <> 0 then
475 FlagsStr := FlagsStr + '|SWP_NOSIZE';
476 if (Flags and SWP_NOZORDER) <> 0 then
477 FlagsStr := FlagsStr + '|SWP_NOZORDER';
478 if (Flags and SWP_SHOWWINDOW) <> 0 then
479 FlagsStr := FlagsStr + '|SWP_SHOWWINDOW';
480 if Length(FlagsStr) > 0 then
481 FlagsStr := Copy(FlagsStr, 2, Length(FlagsStr)-1);
482 Result := FlagsStr;
483 end;
484
485 {------------------------------------------------------------------------------
486 Procedure: GetWin32KeyInfo
487 Params: Event - Requested info
488 KeyCode - the ASCII key code of the eventkey
489 VirtualKey - the virtual key code of the eventkey
490 SysKey - True If the key is a syskey
491 ExtEnded - True If the key is an extended key
492 Toggle - True If the key is a toggle key and its value is on
493 Returns: Nothing
494
495 GetWin32KeyInfo returns information about the given key event
496 ------------------------------------------------------------------------------}
497 {
498 procedure GetWin32KeyInfo(const Event: Integer; var KeyCode, VirtualKey: Integer; var SysKey, Extended, Toggle: Boolean);
499 Const
500 MVK_UNIFY_SIDES = 1;
501 Begin
502 //DebugLn('TRACE:Using function GetWin32KeyInfo which isn''t implemented yet');
503 KeyCode := Word(Event);
504 VirtualKey := MapVirtualKey(KeyCode, MVK_UNIFY_SIDES);
505 SysKey := (VirtualKey = VK_SHIFT) Or (VirtualKey = VK_CONTROL) Or (VirtualKey = VK_MENU);
506 ExtEnded := (SysKey) Or (VirtualKey = VK_INSERT) Or (VirtualKey = VK_HOME) Or (VirtualKey = VK_LEFT) Or (VirtualKey = VK_UP) Or (VirtualKey = VK_RIGHT) Or (VirtualKey = VK_DOWN) Or (VirtualKey = VK_PRIOR) Or (VirtualKey = VK_NEXT) Or (VirtualKey = VK_END) Or (VirtualKey = VK_DIVIDE);
507 Toggle := Lo(GetKeyState(VirtualKey)) = 1;
508 End;
509 }
510
511 {------------------------------------------------------------------------------
512 Function: ObjectToHWND
513 Params: AObject - An LCL Object
514 Returns: The Window handle of the given object
515
516 Returns the Window handle of the given object, 0 if no object available
517 ------------------------------------------------------------------------------}
ObjectToHWNDnull518 function ObjectToHWND(Const AObject: TObject): HWND;
519 Var
520 Handle: HWND;
521 Begin
522 Handle:=0;
523 If not assigned(AObject) Then
524 Begin
525 Assert (False, 'TRACE:[ObjectToHWND] Object not assigned');
526 End
527 Else If (AObject Is TWinControl) Then
528 Begin
529 If TWinControl(AObject).HandleAllocated Then
530 Handle := TWinControl(AObject).Handle
531 End
532 Else If (AObject Is TMenuItem) Then
533 Begin
534 If TMenuItem(AObject).HandleAllocated Then
535 Handle := TMenuItem(AObject).Handle
536 End
537 Else If (AObject Is TMenu) Then
538 Begin
539 If TMenu(AObject).HandleAllocated Then
540 Handle := TMenu(AObject).Items.Handle
541 End
542 // Else If (AObject Is TCommonDialog) Then
543 // Begin
544 // {If TCommonDialog(AObject).HandleAllocated Then }
545 // Handle := TCommonDialog(AObject).Handle
546 // End
547 Else
548 Begin
549 //DebugLn(Format('Trace:[ObjectToHWND] Message received With unhandled class-type <%s>', [AObject.ClassName]));
550 End;
551 Result := Handle;
552 If Handle = 0 Then
553 Assert (False, 'Trace:[ObjectToHWND]****** Warning: handle = 0 *******');
554 end;
555
BytesPerLinenull556 function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
557 begin
558 Result := ((nWidth * nBitsPerPixel + 31) and (not 31) ) div 8;
559 end;
560
561 procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
562 begin
563 case ADesc.BitsPerPixel of
564 1,4,8:
565 begin
566 // palette mode, no offsets
567 ADesc.Format := ricfGray;
568 ADesc.RedPrec := ADesc.BitsPerPixel;
569 ADesc.GreenPrec := 0;
570 ADesc.BluePrec := 0;
571 ADesc.RedShift := 0;
572 ADesc.GreenShift := 0;
573 ADesc.BlueShift := 0;
574 end;
575 16:
576 begin
577 // 5-6-5 mode
578 //roozbeh all changed from 5-5-5 to 5-6-5
579 ADesc.RedPrec := 5;
580 ADesc.GreenPrec := 6;
581 ADesc.BluePrec := 5;
582 ADesc.RedShift := 11;
583 ADesc.GreenShift := 5;
584 ADesc.BlueShift := 0;
585 ADesc.Depth := 16;
586 end;
587 24:
588 begin
589 // 8-8-8 mode
590 ADesc.RedPrec := 8;
591 ADesc.GreenPrec := 8;
592 ADesc.BluePrec := 8;
593 ADesc.RedShift := 16;
594 ADesc.GreenShift := 8;
595 ADesc.BlueShift := 0;
596 end;
597 else // 32:
598 // 8-8-8-8 mode, high byte can be native alpha or custom 1bit maskalpha
599 ADesc.AlphaPrec := 8;
600 ADesc.RedPrec := 8;
601 ADesc.GreenPrec := 8;
602 ADesc.BluePrec := 8;
603 ADesc.AlphaShift := 24;
604 ADesc.RedShift := 16;
605 ADesc.GreenShift := 8;
606 ADesc.BlueShift := 0;
607 ADesc.Depth := 32;
608 end;
609 end;
610
611
612 procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
613 begin
614 ADesc.Init;
615 ADesc.Format := ricfRGBA;
616 ADesc.Depth := ABitmapInfo.bmBitsPixel; // used bits per pixel
617 ADesc.Width := ABitmapInfo.bmWidth;
618 ADesc.Height := ABitmapInfo.bmHeight;
619 ADesc.BitOrder := riboReversedBits;
620 ADesc.ByteOrder := riboLSBFirst;
621 ADesc.LineOrder := riloTopToBottom;
622 ADesc.BitsPerPixel := ABitmapInfo.bmBitsPixel; // bits per pixel. can be greater than Depth.
623 ADesc.LineEnd := rileDWordBoundary;
624
625 if ABitmapInfo.bmBitsPixel <= 8
626 then begin
627 // each pixel is an index in the palette
628 // TODO, ColorCount
629 ADesc.PaletteColorCount := 0;
630 end
631 else ADesc.PaletteColorCount := 0;
632
633 FillRawImageDescriptionColors(ADesc);
634
635 ADesc.MaskBitsPerPixel := 1;
636 ADesc.MaskShift := 0;
637 ADesc.MaskLineEnd := rileWordBoundary; // CreateBitmap requires word boundary
638 ADesc.MaskBitOrder := riboReversedBits;
639 end;
640
WinProc_RawImage_FromBitmapnull641 function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
642 var
643 WinDIB: Windows.TDIBSection;
644 WinBmp: Windows.TBitmap absolute WinDIB.dsBm;
645 ASize: Integer;
646 R: TRect;
647 begin
648 ARawImage.Init;
649 FillChar(WinDIB, SizeOf(WinDIB), 0);
650 ASize := Windows.GetObject(ABitmap, SizeOf(WinDIB), @WinDIB);
651 if ASize = 0
652 then Exit(False);
653
654 //DbgDumpBitmap(ABitmap, 'FromBitmap - Image');
655 //DbgDumpBitmap(AMask, 'FromMask - Mask');
656
657 FillRawImageDescription(WinBmp, ARawImage.Description);
658 // if it is not DIB then alpha in bitmaps is not supported => use 0 alpha prec
659 if ASize < SizeOf(WinDIB) then
660 ARawImage.Description.AlphaPrec := 0;
661
662 if ARect = nil
663 then begin
664 R := Rect(0, 0, WinBmp.bmWidth, WinBmp.bmHeight);
665 end
666 else begin
667 R := ARect^;
668 if R.Top > WinBmp.bmHeight then
669 R.Top := WinBmp.bmHeight;
670 if R.Bottom > WinBmp.bmHeight then
671 R.Bottom := WinBmp.bmHeight;
672 if R.Left > WinBmp.bmWidth then
673 R.Left := WinBmp.bmWidth;
674 if R.Right > WinBmp.bmWidth then
675 R.Right := WinBmp.bmWidth;
676 end;
677
678 ARawImage.Description.Width := R.Right - R.Left;
679 ARawImage.Description.Height := R.Bottom - R.Top;
680
681 // copy bitmap
682 Result := GetBitmapBytes(WinBmp, ABitmap, R, ARawImage.Description.LineEnd, ARawImage.Description.LineOrder, ARawImage.Data, ARawImage.DataSize);
683
684 // check mask
685 if AMask <> 0 then
686 begin
687 if Windows.GetObject(AMask, SizeOf(WinBmp), @WinBmp) = 0
688 then Exit(False);
689
690 Result := GetBitmapBytes(WinBmp, AMask, R, ARawImage.Description.MaskLineEnd, ARawImage.Description.LineOrder, ARawImage.Mask, ARawImage.MaskSize);
691 end
692 else begin
693 ARawImage.Description.MaskBitsPerPixel := 0;
694 end;
695 end;
696
697 {------------------------------------------------------------------------------
698 Function: RawImage_CreateBitmaps
699 Params: ARawImage:
700 ABitmap:
701 AMask:
702 ASkipMask: When set there is no mask created
703 Returns:
704
705 ------------------------------------------------------------------------------}
706 {$ifdef WinCE}
WinProc_RawImage_CreateBitmapsnull707 function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
708 var
709 ADesc: TRawImageDescription absolute ARawImage.Description;
710 DC: HDC;
711 BitsPtr: Pointer;
712 DataSize: PtrUInt;
713 begin
714 Result := False;
715 AMask := 0;
716
717 if not ((ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary)) then
718 begin
719 DC := Windows.GetDC(0);
720 AMask := 0;
721 ABitmap := CreateDIBSectionFromDescription(DC, ADesc, BitsPtr);
722 //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image');
723 Windows.ReleaseDC(0, DC);
724
725 Result := ABitmap <> 0;
726 if not Result then Exit;
727 if BitsPtr = nil then Exit;
728
729 // copy the image data
730 DataSize := BytesPerLine(ADesc.Width, ADesc.BitsPerPixel) * ADesc.Height;
731 if DataSize > ARawImage.DataSize
732 then DataSize := ARawImage.DataSize;
733 Move(ARawImage.Data^, BitsPtr^, DataSize);
734 end
735 else
736 ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data);
737
738 if ASkipMask then Exit(True);
739
740 AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask);
741 //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Mask');
742 Result := AMask <> 0;
743 end;
744 {$else}
WinProc_RawImage_CreateBitmapsnull745 function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
746 var
747 ADesc: TRawImageDescription absolute ARawImage.Description;
748
DoBitmapnull749 function DoBitmap: Boolean;
750 var
751 DC: HDC;
752 Info: record
753 Header: Windows.TBitmapInfoHeader;
754 Colors: array[0..1] of Cardinal; // reserve extra color for mono bitmaps
755 end;
756 DstLinePtr, SrcLinePtr: PByte;
757 SrcPixelPtr, DstPixelPtr: PByte;
758 DstLineSize, SrcLineSize: PtrUInt;
759 x, y: Integer;
760 Ridx, Gidx, Bidx, Aidx, Align, SrcBytes, DstBpp: Byte;
761 begin
762 if (ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary)
763 then begin
764 // default BW, word aligned bitmap
765 ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data);
766 Exit(ABitmap <> 0);
767 end;
768
769 // for 24 bits images, BPP can be 24 or 32
770 // 32 shouldn't be use since we don't fill the alpha channel
771
772 if ADesc.Depth = 24
773 then DstBpp := 24
774 else DstBpp := ADesc.BitsPerPixel;
775
776 FillChar(Info, SizeOf(Info), 0);
777 Info.Header.biSize := SizeOf(Info.Header);
778 Info.Header.biWidth := ADesc.Width;
779 if ADesc.LineOrder = riloTopToBottom
780 then Info.Header.biHeight := -ADesc.Height // create top to bottom
781 else Info.Header.biHeight := ADesc.Height; // create bottom to top
782 Info.Header.biPlanes := 1;
783 Info.Header.biBitCount := DstBpp;
784 Info.Header.biCompression := BI_RGB;
785 {Info.Header.biSizeImage := 0;}
786 { first color is black, second color is white, for monochrome bitmap }
787 Info.Colors[1] := $FFFFFFFF;
788
789 DC := Windows.GetDC(0);
790 // Use createDIBSection, since only devicedepth bitmaps can be selected into a DC
791 // when they are created with createDIBitmap
792 // ABitmap := Windows.CreateDIBitmap(DC, Info.Header, CBM_INIT, ARawImage.Data, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS);
793 ABitmap := Windows.CreateDIBSection(DC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, DstLinePtr, 0, 0);
794 Windows.ReleaseDC(0, DC);
795
796 if ABitmap = 0
797 then begin
798 DebugLn('Windows.CreateDIBSection returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError));
799 Exit(False);
800 end;
801 if DstLinePtr = nil then Exit(False);
802
803 DstLineSize := Windows.MulDiv(DstBpp, ADesc.Width, 8);
804 // align to DWord
805 Align := DstLineSize and 3;
806 if Align > 0
807 then Inc(DstLineSize, 4 - Align);
808
809 SrcLinePtr := ARawImage.Data;
810 SrcLineSize := ADesc.BytesPerLine;
811
812 // copy the image data
813 if ADesc.Depth >= 24
814 then begin
815 // check if a pixel copy is needed
816 // 1) Windows uses alpha channel in 32 bpp modes, despite documentation statement that it is ignored. Tested under Windows XP SP3
817 // Wine also relies on this undocumented behaviour!
818 // So, we need to cut unused A-channel, otherwise we would get black image
819 //
820 // 2) incompatible channel order
821 ADesc.GetRGBIndices(Ridx, Gidx, Bidx, Aidx);
822
823 if ((ADesc.BitsPerPixel = 32) and (ADesc.Depth = 24))
824 or (Bidx <> 0) or (Gidx <> 1) or (Ridx <> 2)
825 then begin
826 // copy pixels
827 SrcBytes := ADesc.BitsPerPixel div 8;
828
829 for y := 0 to ADesc.Height - 1 do
830 begin
831 DstPixelPtr := DstLinePtr;
832 SrcPixelPtr := SrcLinePtr;
833 for x := 0 to ADesc.Width - 1 do
834 begin
835 DstPixelPtr[0] := SrcPixelPtr[Bidx];
836 DstPixelPtr[1] := SrcPixelPtr[Gidx];
837 DstPixelPtr[2] := SrcPixelPtr[Ridx];
838
839 Inc(DstPixelPtr, 3); //move to the next dest RGB triple
840 Inc(SrcPixelPtr, SrcBytes);
841 end;
842
843 Inc(DstLinePtr, DstLineSize);
844 Inc(SrcLinePtr, SrcLineSize);
845 end;
846
847 Exit(True);
848 end;
849 end;
850
851 // no pixelcopy needed
852 // check if we can move using one call
853 if ADesc.LineEnd = rileDWordBoundary
854 then begin
855 Move(SrcLinePtr^, DstLinePtr^, DstLineSize * ADesc.Height);
856 Exit(True);
857 end;
858
859 //Can't use just one move, as different alignment
860 for y := 0 to ADesc.Height - 1 do
861 begin
862 Move(SrcLinePtr^, DstLinePtr^, DstLineSize);
863 Inc(DstLinePtr, DstLineSize);
864 Inc(SrcLinePtr, SrcLineSize);
865 end;
866
867 Result := True;
868 end;
869
870 begin
871 AMask := 0;
872 Result := DoBitmap;
873 if not Result then Exit;
874
875 //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image');
876 if ASkipMask then Exit;
877
878 AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask);
879 if AMask = 0 then
880 DebugLn('Windows.CreateBitmap returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError));
881 Result := AMask <> 0;
882 //DbgDumpBitmap(AMask, 'CreateBitmaps - Mask');
883 end;
884 {$endif}
885
886 function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
887 function GetMask(APrec, AShift: Byte): Cardinal;
888 begin
889 Result := ($FFFFFFFF shr (32-APrec)) shl AShift;
890 end;
891
892 var
893 Info: record
894 Header: Windows.TBitmapInfoHeader;
895 Colors: array[0..3] of Cardinal; // reserve extra color for colormasks
896 end;
897 begin
898 FillChar(Info, sizeof(Info), 0);
899 Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader);
900 Info.Header.biWidth := ADesc.Width;
901 Info.Header.biHeight := -ADesc.Height;
902 Info.Header.biPlanes := 1;
903 Info.Header.biBitCount := ADesc.BitsPerPixel;
904 // TODO: palette support
905 Info.Header.biClrUsed := 0;
906 Info.Header.biClrImportant := 0;
907 Info.Header.biSizeImage := BytesPerLine(Info.Header.biWidth, Info.Header.biBitCount) * ADesc.Height;
908 // CE only supports bitfields
909 if ADesc.BitsPerPixel > 8
910 then Info.Header.biCompression := BI_BITFIELDS
911 else Info.Header.biCompression := BI_RGB;
912
913 if ADesc.BitsPerPixel = 1
914 then begin
915 // mono bitmap: first color is black, second is white
916 Info.Colors[1] := $FFFFFFFF;
917 end
918 else begin
919 // when 24bpp, CE only supports B8G8R8 encoding
920 // TODO: check the description
921 Info.Colors[0] := GetMask(ADesc.RedPrec, ADesc.RedShift);
922 Info.Colors[1] := GetMask(ADesc.GreenPrec, ADesc.GreenShift);
923 Info.Colors[2] := GetMask(ADesc.BluePrec, ADesc.BlueShift);
924 end;
925
926 // Use createDIBSection, since only devicedepth bitmaps can be selected into a DC
927 // when they are created with createDIBitmap
928 Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, ABitsPtr, 0, 0);
929
930 //DbgDumpBitmap(Result, 'CreateDIBSectionFromDescription - Image');
931 end;
932
933 function CreateDIBSectionFromDDB(ASource: HBitmap; out ABitsPtr: Pointer): HBitmap;
934 var
935 ADC, SrcDC, DstDC: HDC;
936 ADesc: TRawImageDescription;
937 SrcOldBm, DstOldBm: HBitmap;
938 begin
939 Result := 0;
940
941 // get source bitmap description
942 if not RawImage_DescriptionFromBitmap(ASource, ADesc) then
943 Exit;
944
945 // create apropriate dib section
946 ADC := GetDC(0);
947 Result := CreateDIBSectionFromDescription(ADC, ADesc, ABitsPtr);
948 ReleaseDC(0, ADC);
949
950 if Result = 0 then
951 Exit;
952
953 // copy source bitmap into destination
954 SrcDC := CreateCompatibleDC(0);
955 SrcOldBm := SelectObject(SrcDC, ASource);
956 DstDC := CreateCompatibleDC(0);
957 DstOldBm := SelectObject(DstDC, Result);
958 Windows.BitBlt(DstDC, 0, 0, ADesc.Width, ADesc.Height, SrcDC, 0, 0, SRCCOPY);
959 SelectObject(SrcDC, SrcOldBm);
960 SelectObject(DstDC, DstOldBm);
961 DeleteDC(SrcDC);
962 DeleteDC(DstDC);
963 end;
964
965 {$ifndef Wince}
966 function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP): TRawImageLineOrder;
967 procedure DbgLog(const AFunc: String);
968 begin
969 DebugLn('GetBitmapOrder - GetDIBits ', AFunc, ' failed: ', GetLastErrorText(Windows.GetLastError));
970 end;
971
972 var
973 SrcPixel: PCardinal absolute AWinBmp.bmBits;
974 OrgPixel, TstPixel: Cardinal;
975 Scanline: Pointer;
976 DC: HDC;
977 Info: record
978 Header: Windows.TBitmapInfoHeader;
979 Colors: array[Byte] of Cardinal; // reserve extra color for colormasks
980 end;
981
982 FullScanLine: Boolean; // win9x requires a full scanline to be retrieved
983 // others won't fail when one pixel is requested
984 begin
985 if AWinBmp.bmBits = nil
986 then begin
987 // no DIBsection so always bottom-up
988 Exit(riloBottomToTop);
989 end;
990
991 // try to figure out the orientation of the given bitmap.
992 // Unfortunately MS doesn't provide a direct function for this.
993 // So modify the first pixel to see if it changes. This pixel is always part
994 // of the first scanline of the given bitmap.
995 // When we request the data through GetDIBits as bottom-up, windows adjusts
996 // the data when it is a top-down. So if the pixel doesn't change the bitmap
997 // was internally a top-down image.
998
999 FullScanLine := Win32Platform = VER_PLATFORM_WIN32_WINDOWS;
1000 if FullScanLine
1001 then ScanLine := GetMem(AWinBmp.bmWidthBytes);
1002
1003 FillChar(Info.Header, sizeof(Windows.TBitmapInfoHeader), 0);
1004 Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader);
1005 DC := Windows.GetDC(0);
1006 if Windows.GetDIBits(DC, ABitmap, 0, 1, nil, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1007 then begin
1008 DbgLog('Getinfo');
1009 // failed ???
1010 Windows.ReleaseDC(0, DC);
1011 Exit(riloBottomToTop);
1012 end;
1013
1014 // Get only 1 pixel (or full scanline for win9x)
1015 OrgPixel := 0;
1016 if FullScanLine
1017 then begin
1018 if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1019 then DbgLog('OrgPixel')
1020 else OrgPixel := PCardinal(ScanLine)^;
1021 end
1022 else begin
1023 Info.Header.biWidth := 1;
1024 if Windows.GetDIBits(DC, ABitmap, 0, 1, @OrgPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1025 then DbgLog('OrgPixel');
1026 end;
1027
1028 // modify pixel
1029 SrcPixel^ := not SrcPixel^;
1030
1031 // get test
1032 TstPixel := 0;
1033 if FullScanLine
1034 then begin
1035 if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1036 then DbgLog('TstPixel')
1037 else TstPixel := PCardinal(ScanLine)^;
1038 end
1039 else begin
1040 if Windows.GetDIBits(DC, ABitmap, 0, 1, @TstPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1041 then DbgLog('TstPixel');
1042 end;
1043
1044 if OrgPixel = TstPixel
1045 then Result := riloTopToBottom
1046 else Result := riloBottomToTop;
1047
1048 // restore pixel & cleanup
1049 SrcPixel^ := not SrcPixel^;
1050 Windows.ReleaseDC(0, DC);
1051 if FullScanLine
1052 then FreeMem(Scanline);
1053 end;
1054 {$endif}
1055
1056 {$ifdef WinCE}
GetBitmapBytesnull1057 //function GetBitmapBytes(ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; var AData: Pointer; var ADataSize: PtrUInt): Boolean;
1058 function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
1059 var
1060 Section: Windows.TDIBSection;
1061 DIBCopy: HBitmap;
1062 DIBData: Pointer;
1063 begin
1064 Result := False;
1065 // first try if the bitmap is created as section
1066 if (Windows.GetObject(ABitmap, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
1067 then begin
1068 with Section.dsBm do
1069 Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
1070 Exit;
1071 end;
1072
1073 // bitmap is not a section, retrieve only bitmap
1074 if Windows.GetObject(ABitmap, SizeOf(Section.dsBm), @Section) = 0
1075 then Exit;
1076
1077 DIBCopy := CreateDIBSectionFromDDB(ABitmap, DIBData);
1078 if DIBCopy = 0 then
1079 Exit;
1080 if (Windows.GetObject(DIBCopy, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
1081 then begin
1082 with Section.dsBm do
1083 Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
1084 end;
1085
1086 DeleteObject(DIBCopy);
1087
1088 Result := True;
1089 end;
1090 {$else}
GetBitmapBytesnull1091 function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
1092 var
1093 DC: HDC;
1094 Info: record
1095 Header: Windows.TBitmapInfoHeader;
1096 Colors: array[Byte] of TRGBQuad; // reserve extra colors for palette (256 max)
1097 end;
1098 H: Cardinal;
1099 R: TRect;
1100 SrcData: PByte;
1101 SrcSize: PtrUInt;
1102 SrcLineBytes: Cardinal;
1103 SrcLineOrder: TRawImageLineOrder;
1104 StartScan: Integer;
1105 begin
1106 SrcLineOrder := GetBitmapOrder(AWinBmp, ABitmap);
1107 SrcLineBytes := (AWinBmp.bmWidthBytes + 3) and not 3;
1108
1109 if AWinBmp.bmBits <> nil
1110 then begin
1111 // this is bitmapsection data :) we can just copy the bits
1112
1113 // We cannot trust windows with bmWidthBytes. Use SrcLineBytes which takes
1114 // DWORD alignment into consideration
1115 with AWinBmp do
1116 Result := CopyImageData(bmWidth, bmHeight, SrcLineBytes, bmBitsPixel, bmBits, ARect, SrcLineOrder, ALineOrder, ALineEnd, AData, ADataSize);
1117 Exit;
1118 end;
1119
1120 // retrieve the data though GetDIBits
1121
1122 // initialize bitmapinfo structure
1123 Info.Header.biSize := sizeof(Info.Header);
1124 Info.Header.biPlanes := 1;
1125 Info.Header.biBitCount := AWinBmp.bmBitsPixel;
1126 Info.Header.biCompression := BI_RGB;
1127 Info.Header.biSizeImage := 0;
1128
1129 Info.Header.biWidth := AWinBmp.bmWidth;
1130 H := ARect.Bottom - ARect.Top;
1131 // request a top-down DIB
1132 if AWinBmp.bmHeight > 0
1133 then begin
1134 Info.Header.biHeight := -AWinBmp.bmHeight;
1135 StartScan := AWinBmp.bmHeight - ARect.Bottom;
1136 end
1137 else begin
1138 Info.Header.biHeight := AWinBmp.bmHeight;
1139 StartScan := ARect.Top;
1140 end;
1141 // adjust height
1142 if StartScan < 0
1143 then begin
1144 Inc(H, StartScan);
1145 StartScan := 0;
1146 end;
1147
1148 // alloc buffer
1149 SrcSize := SrcLineBytes * H;
1150 GetMem(SrcData, SrcSize);
1151
1152 DC := Windows.GetDC(0);
1153 Result := Windows.GetDIBits(DC, ABitmap, StartScan, H, SrcData, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) <> 0;
1154 Windows.ReleaseDC(0, DC);
1155
1156 // since we only got the needed scanlines, adjust top and bottom
1157 R.Left := ARect.Left;
1158 R.Top := 0;
1159 R.Right := ARect.Right;
1160 R.Bottom := H;
1161
1162 with Info.Header do
1163 Result := Result and CopyImageData(biWidth, H, SrcLineBytes, biBitCount, SrcData, R, riloTopToBottom, ALineOrder, ALineEnd, AData, ADataSize);
1164
1165 FreeMem(SrcData);
1166 end;
1167 {$endif}
1168
IsAlphaBitmapnull1169 function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
1170 var
1171 Info: Windows.BITMAP;
1172 begin
1173 FillChar(Info, SizeOf(Info), 0);
1174 Result := (GetObject(ABitmap, SizeOf(Info), @Info) <> 0)
1175 and (Info.bmBitsPixel = 32);
1176 end;
1177
IsAlphaDCnull1178 function IsAlphaDC(ADC: HDC): Boolean;
1179 begin
1180 Result := (GetObjectType(ADC) = OBJ_MEMDC)
1181 and IsAlphaBitmap(GetCurrentObject(ADC, OBJ_BITMAP));
1182 end;
1183
GetLastErrorTextnull1184 function GetLastErrorText(AErrorCode: Cardinal): WideString;
1185 var
1186 r: cardinal;
1187 tmp: PWideChar;
1188 begin
1189 tmp := nil;
1190 r := Windows.FormatMessage(
1191 FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
1192 nil, AErrorCode, LANG_NEUTRAL, @tmp, 0, nil);
1193
1194 if r = 0 then Exit('');
1195
1196 Result := tmp;
1197 SetLength(Result, Length(Result)-2);
1198
1199 if tmp <> nil
1200 then LocalFree(HLOCAL(tmp));
1201 end;
1202
1203 (***********************************************************************
1204 Widget member Functions
1205 ************************************************************************)
1206
1207 {-------------------------------------------------------------------------------
1208 function LCLBoundsNeedsUpdate(Sender: TWinControl;
1209 SendSizeMsgOnDiff: boolean): boolean;
1210
1211 Returns true if LCL bounds and win32 bounds differ for the control.
1212 -------------------------------------------------------------------------------}
LCLControlSizeNeedsUpdatenull1213 function LCLControlSizeNeedsUpdate(Sender: TWinControl;
1214 SendSizeMsgOnDiff: boolean): boolean;
1215 var
1216 Window:HWND;
1217 LMessage: TLMSize;
1218 IntfWidth, IntfHeight: integer;
1219 begin
1220 Result:=false;
1221 Window:= Sender.Handle;
1222 LCLIntf.GetWindowSize(Window, IntfWidth, IntfHeight);
1223 if (Sender.Width = IntfWidth)
1224 and (Sender.Height = IntfHeight)
1225 and (not Sender.ClientRectNeedsInterfaceUpdate) then
1226 exit;
1227 Result:=true;
1228 if SendSizeMsgOnDiff then
1229 begin
1230 //writeln('LCLBoundsNeedsUpdate B ',TheWinControl.Name,':',TheWinControl.ClassName,' Sending WM_SIZE');
1231 Sender.InvalidateClientRectCache(true);
1232 // send message directly to LCL, some controls not subclassed -> message
1233 // never reaches LCL
1234 with LMessage do
1235 begin
1236 Msg := LM_SIZE;
1237 SizeType := SIZE_RESTORED or Size_SourceIsInterface;
1238 Width := IntfWidth;
1239 Height := IntfHeight;
1240 end;
1241 DeliverMessage(Sender, LMessage);
1242 end;
1243 end;
1244
1245 {-------------------------------------------------------------------------------
1246 function GetLCLClientOriginOffset(Sender: TObject;
1247 var LeftOffset, TopOffset: integer): boolean;
1248
1249 Returns the difference between the client origin of a win32 handle
1250 and the definition of the LCL counterpart.
1251 For example:
1252 TGroupBox's client area is the area inside the groupbox frame.
1253 Hence, the LeftOffset is the frame width and the TopOffset is the caption
1254 height.
1255 -------------------------------------------------------------------------------}
GetLCLClientBoundsOffsetnull1256 function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
1257 var
1258 TM: TextMetric;
1259 DC: HDC;
1260 Handle: HWND;
1261 TheWinControl: TWinControl;
1262 ARect: TRect;
1263 Ignore: Integer;
1264 begin
1265 Result:=false;
1266 if (Sender = nil) or (not (Sender is TWinControl)) then exit;
1267 TheWinControl:=TWinControl(Sender);
1268 FillChar(ORect, SizeOf(ORect), 0);
1269 if not TheWinControl.HandleAllocated then exit;
1270 Handle := TheWinControl.Handle;
1271 if TheWinControl is TScrollingWinControl then
1272 with TScrollingWinControl(TheWinControl) do
1273 begin
1274 if HorzScrollBar <> nil then
1275 begin
1276 // left and right bounds are shifted by scroll position
1277 ORect.Left := -HorzScrollBar.Position;
1278 ORect.Right := -HorzScrollBar.Position;
1279 end;
1280 if VertScrollBar <> nil then
1281 begin
1282 // top and bottom bounds are shifted by scroll position
1283 ORect.Top := -VertScrollBar.Position;
1284 ORect.Bottom := -VertScrollBar.Position;
1285 end;
1286 end;
1287
1288 {$ifdef DEBUG_WINDOW_ORG}
1289 DebugLn(
1290 Format('GetLCLClientBoundsOffset Name=%s OLeft=%d OTop=%d ORight=%d OBottom=%d',
1291 [TheWinControl.Name, ORect.Left, ORect.Top, ORect.Right, ORect.Bottom]));
1292 {$endif}
1293
1294 Result := True;
1295 end;
1296
GetLCLClientBoundsOffsetnull1297 function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean;
1298 var
1299 OwnerObject: TObject;
1300 begin
1301 OwnerObject := TWindowInfo(Handle).LCLForm;
1302 Result:=GetLCLClientBoundsOffset(OwnerObject, Rect);
1303 end;
1304
1305 procedure LCLBoundsToWin32Bounds(Sender: TObject; var Left, Top: Integer);
1306 var
1307 ORect: TRect;
1308 Begin
1309 if (Sender=nil) or (not (Sender is TWinControl)) then exit;
1310 if not GetLCLClientBoundsOffset(TWinControl(Sender).Parent, ORect) then exit;
1311 inc(Left, ORect.Left);
1312 inc(Top, ORect.Top);
1313 End;
1314
1315 procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
1316 {$NOTE Should be moved to WSWin32Forms, if the windowproc is splitted}
1317 var
1318 SizeRect: Windows.RECT;
1319 BorderStyle: TFormBorderStyle;
1320 begin
1321 with SizeRect do
1322 begin
1323 Left := 0;
1324 Top := 0;
1325 Right := AWidth;
1326 Bottom := AHeight;
1327 end;
1328 BorderStyle := Form.BorderStyle;
1329 Windows.AdjustWindowRectEx(@SizeRect, BorderStyleToWinAPIFlags(
1330 BorderStyle), false, BorderStyleToWinAPIFlagsEx(Form, BorderStyle));
1331 AWidth := SizeRect.Right - SizeRect.Left;
1332 AHeight := SizeRect.Bottom - SizeRect.Top;
1333 end;
1334
1335 procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
1336 var
1337 parRect, winRect: Windows.TRect;
1338 begin
1339 Windows.GetWindowRect(Window, @winRect);
1340 Windows.GetWindowRect(Parent, @parRect);
1341 Left := winRect.Left - parRect.Left;
1342 Top := winRect.Top - parRect.Top;
1343 end;
1344
GetWindowInfonull1345 function GetWindowInfo(AWindow: HWND): TWindowInfo;
1346 begin
1347 Result := TWindowInfo(FindFormWithNativeHandle(AWindow));
1348 if Result = nil then Result := DefaultWindowInfo;
1349 end;
1350
1351 {
1352 Updates the window style of the window indicated by Handle.
1353 The new style is the Style parameter.
1354 Only the bits set in the StyleMask are changed,
1355 the other bits remain untouched.
1356 If the bits in the StyleMask are not used in the Style,
1357 there are cleared.
1358 }
1359 procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
1360 var
1361 CurrentStyle,
1362 NewStyle : PtrInt;
1363 begin
1364 CurrentStyle := Windows.GetWindowLong(Handle, GWL_STYLE);
1365 NewStyle := (Style and StyleMask) or (CurrentStyle and (not StyleMask));
1366 Windows.SetWindowLong(Handle, GWL_STYLE, NewStyle);
1367 end;
1368
BorderStyleToWinAPIFlagsnull1369 function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
1370 begin
1371 Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
1372 case Application.ApplicationType of
1373 { Under Desktop or Handheld mode we get an application which
1374 looks similar to a desktop one, with sizable windows }
1375 atDesktop:
1376 begin
1377 case Style of
1378 bsSizeable, bsSizeToolWin:
1379 Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
1380 bsSingle, bsToolWindow:
1381 Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
1382 bsDialog:
1383 Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
1384 bsNone:
1385 Result := Result or WS_POPUP;
1386 end;
1387 end;
1388 { Under PDA or Smartphone modes most windows are enlarged to fit the screen
1389 Dialogs and borderless windows are exceptions }
1390 atPDA, atKeyPadDevice, atDefault:
1391 begin
1392 case Style of
1393 bsDialog:
1394 Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
1395 bsNone:
1396 Result := Result or WS_POPUP;
1397 else
1398 Result := 0; // Never add WS_VISIBLE here, bug http://bugs.freepascal.org/view.php?id=12193
1399 end;
1400 end;
1401 end;
1402 end;
1403
BorderStyleToWinAPIFlagsExnull1404 function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
1405 begin
1406 Result := 0;
1407
1408 case Application.ApplicationType of
1409
1410 atDesktop:
1411 begin
1412 case Style of
1413 bsDialog:
1414 Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
1415 bsToolWindow, bsSizeToolWin:
1416 Result := WS_EX_TOOLWINDOW;
1417 end;
1418 end;
1419
1420 atPDA, atKeyPadDevice, atDefault:
1421 begin
1422 {$ifdef WinCE}
1423 // Adds an "OK" close button to the title bar instead of the standard
1424 // "X" minimize button, unless the developer overrides that decision
1425 case CDWidgetSet.WinCETitlePolicy of
1426
1427 tpAlwaysUseOKButton: Result := WS_EX_CAPTIONOKBTN;
1428
1429
1430 tpControlWithBorderIcons:
1431 begin
1432 if not (biMinimize in AForm.BorderIcons) then Result := WS_EX_CAPTIONOKBTN;
1433 end;
1434 else
1435 if Style = bsDialog then Result := WS_EX_CAPTIONOKBTN;
1436 end;
1437 {$endif}
1438 end;
1439
1440 end;
1441 end;
1442
GetFileVersionnull1443 function GetFileVersion(FileName: string): dword;
1444 var
1445 buf: pointer;
1446 lenBuf: dword;
1447 fixedInfo: ^VS_FIXEDFILEINFO;
1448 WideBuffer: widestring;
1449 begin
1450 Result := $FFFFFFFF;
1451 WideBuffer := UTF8Decode(FileName);
1452 lenBuf := GetFileVersionInfoSizeW(PWideChar(WideBuffer), lenBuf);
1453 if lenBuf > 0 then
1454 begin
1455 GetMem(buf, lenBuf);
1456 if GetFileVersionInfoW(PWideChar(WideBuffer), 0, lenBuf, buf) then
1457 begin
1458 VerQueryValue(buf, '\', pointer(fixedInfo), lenBuf);
1459 Result := fixedInfo^.dwFileVersionMS;
1460 end;
1461 FreeMem(buf);
1462 end;
1463 end;
1464
EnumStayOnTopRemovenull1465 function EnumStayOnTopRemove(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
1466 var
1467 StayOnTopWindowsInfo: PStayOnTopWindowsInfo absolute Param;
1468 lWindowInfo: TWindowInfo;
1469 lWinControl: TWinControl;
1470 begin
1471 { Result := True;
1472 if ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0) then
1473 begin
1474 // Don't remove system-wide stay on top, unless desired
1475 if not StayOnTopWindowsInfo^.SystemTopAlso then
1476 begin
1477 lWindowInfo := TWindowInfo(FindFormWithNativeHandle(Handle));
1478 if Assigned(lWindowInfo) then
1479 begin
1480 lWinControl := lWindowInfo.LCLForm;
1481 if (lWinControl is TCustomForm) and
1482 (TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then
1483 Exit;
1484 end;
1485 end;
1486
1487 StayOnTopWindowsInfo^.StayOnTopList.Add(Pointer(Handle));
1488 end;}
1489 end;
1490
1491 procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
1492 var
1493 StayOnTopWindowsInfo: PStayOnTopWindowsInfo;
1494 WindowInfo: TWindowInfo;
1495 I: Integer;
1496 begin
1497 { //WriteLn('RemoveStayOnTopFlags ', InRemoveStayOnTopFlags);
1498 if InRemoveStayOnTopFlags = 0 then
1499 begin
1500 New(StayOnTopWindowsInfo);
1501 StayOnTopWindowsInfo^.AppHandle := AppHandle;
1502 StayOnTopWindowsInfo^.SystemTopAlso := ASystemTopAlso;
1503 StayOnTopWindowsInfo^.StayOnTopList := TList.Create;
1504 WindowInfo := GetWindowInfo(AppHandle);
1505 WindowInfo^.StayOnTopList := StayOnTopWindowsInfo^.StayOnTopList;
1506 EnumThreadWindows(GetWindowThreadProcessId(AppHandle, nil),
1507 @EnumStayOnTopRemove, LPARAM(StayOnTopWindowsInfo));
1508 for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
1509 SetWindowPos(HWND(WindowInfo^.StayOnTopList[I]), HWND_NOTOPMOST, 0, 0, 0, 0,
1510 SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1511 Dispose(StayOnTopWindowsInfo);
1512 end;
1513 inc(InRemoveStayOnTopFlags);}
1514 end;
1515
1516 procedure RestoreStayOnTopFlags(AppHandle: HWND);
1517 var
1518 WindowInfo: TWindowInfo;
1519 I: integer;
1520 begin
1521 { //WriteLn('RestoreStayOnTopFlags ', InRemoveStayOnTopFlags);
1522 if InRemoveStayOnTopFlags = 1 then
1523 begin
1524 WindowInfo := GetWindowInfo(AppHandle);
1525 if WindowInfo^.StayOnTopList <> nil then
1526 begin
1527 for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
1528 SetWindowPos(HWND(WindowInfo^.StayOnTopList.Items[I]),
1529 HWND_TOPMOST, 0, 0, 0, 0,
1530 SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1531 FreeAndNil(WindowInfo^.StayOnTopList);
1532 end;
1533 end;
1534 if InRemoveStayOnTopFlags > 0 then
1535 dec(InRemoveStayOnTopFlags);}
1536 end;
1537
WndClassNamenull1538 function WndClassName(Wnd: HWND): String; inline;
1539 var
1540 winClassName: array[0..19] of widechar;
1541 begin
1542 GetClassName(Wnd, @winClassName, 20);
1543 Result := winClassName;
1544 end;
1545
IsAlienWindownull1546 function IsAlienWindow(Wnd: HWND): Boolean;
1547
1548 const
1549 // list window class names is taken here:
1550 // http://www.pocketpcdn.com/print/articles/?&atb.set(c_id)=51&atb.set(a_id)=7165&atb.perform(details)=
1551 AlienWindowClasses: array[0..7] of String =
1552 (
1553 'menu_worker', // can be also found by SHFindMenuBar
1554 'MS_SOFTKEY_CE_1.0', // google about that one. as I understand it related to bottom menu too
1555 'Default Ime',
1556 'Ime',
1557 'static',
1558 'OLEAUT32',
1559 'FAKEIMEUI',
1560 'tooltips_class32'
1561 );
1562
1563 var
1564 i: integer;
1565 WndName: String;
1566 begin
1567 WndName := WndClassName(Wnd);
1568 Result := False;
1569 for i := Low(AlienWindowClasses) to High(AlienWindowClasses) do
1570 if WndName = AlienWindowClasses[i] then
1571 Exit(True);
1572 end;
1573
1574 {procedure LogWindow(Window: HWND);
1575 begin
1576 DbgAppendToFile(ExtractFilePath(ParamStr(0)) + '1.log',
1577 'Window = ' + IntToStr(Window) + ' ClassName = ' + WndClassName(Window) + ' Thread id = ' + IntToStr(GetWindowThreadProcessId(Window, nil)));
1578 end;}
1579
MeasureTextnull1580 function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
1581 var
1582 textSize: Windows.SIZE;
1583 winHandle: HWND;
1584 canvasHandle: HDC;
1585 oldFontHandle: HFONT;
1586 begin
1587 winHandle := AWinControl.Handle;
1588 canvasHandle := GetDC(winHandle);
1589 oldFontHandle := SelectObject(canvasHandle, Windows.SendMessage(winHandle, WM_GetFont, 0, 0));
1590 DeleteAmpersands(Text);
1591
1592 Result := LCLIntf.GetTextExtentPoint32(canvasHandle, PChar(Text), Length(Text), textSize);
1593
1594 if Result then
1595 begin
1596 Width := textSize.cx;
1597 Height := textSize.cy;
1598 end;
1599 SelectObject(canvasHandle, oldFontHandle);
1600 ReleaseDC(winHandle, canvasHandle);
1601 end;
1602
GetControlTextnull1603 function GetControlText(AHandle: HWND): string;
1604 var
1605 TextLen: dword;
1606 tmpWideStr: WideString;
1607 begin
1608 TextLen := GetWindowTextLength(AHandle);
1609 SetLength(tmpWideStr, TextLen+1);
1610 GetWindowTextW(AHandle, PWideChar(tmpWideStr), TextLen + 1);
1611 Result := UTF8Encode(tmpWideStr);
1612 end;
1613
1614 procedure WideStrCopy(Dest, Src: PWideChar);
1615 var
1616 counter : longint;
1617 Begin
1618 counter := 0;
1619 while Src[counter] <> #0 do
1620 begin
1621 Dest[counter] := Src[counter];
1622 Inc(counter);
1623 end;
1624 Dest[counter] := #0;
1625 end;
1626
1627 { Exactly equal to StrLCopy but for PWideChars
1628 Copyes a widestring up to a maximal length, in WideChars }
WideStrLCopynull1629 function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
1630 var
1631 counter: SizeInt;
1632 begin
1633 counter := 0;
1634
1635 while (Source[counter] <> #0) and (counter < MaxLen) do
1636 begin
1637 Dest[counter] := Source[counter];
1638 Inc(counter);
1639 end;
1640
1641 { terminate the string }
1642 Dest[counter] := #0;
1643 Result := Dest;
1644 end;
1645
WideStrCmpnull1646 function WideStrCmp(W1, W2: PWideChar): Integer;
1647 var
1648 counter: Integer;
1649 Begin
1650 counter := 0;
1651 While W1[counter] = W2[counter] do
1652 Begin
1653 if (W2[counter] = #0) or (W1[counter] = #0) then
1654 break;
1655 Inc(counter);
1656 end;
1657 Result := ord(W1[counter]) - ord(W2[counter]);
1658 end;
1659
GetWinCEPlatformnull1660 function GetWinCEPlatform: TApplicationType;
1661 {$ifdef MSWindows}
1662 begin
1663 Result := atDesktop;
1664 end;
1665 {$else}
1666 var
1667 buf: array[0..50] of WideChar;
1668 begin
1669 Result := atDefault;
1670
1671 if Windows.SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then
1672 begin
1673 if WideStrCmp(@buf, 'PocketPC') = 0 then
1674 Result := atPDA
1675 else if WideStrCmp(@buf, 'SmartPhone') = 0 then
1676 Result := atKeyPadDevice
1677 else
1678 // Other devices can set anything for the platform name,
1679 // see http://bugs.freepascal.org/view.php?id=16615
1680 // Here we just suppose that they are atDesktop
1681 Result := atDesktop;
1682 end
1683 else if GetLastError = ERROR_ACCESS_DENIED then
1684 Result := atKeyPadDevice
1685 else
1686 Result := atPDA;
1687 end;
1688 {$endif}
1689
IsHiResModenull1690 function IsHiResMode: Boolean;
1691 begin
1692 {$ifdef MSWindows}
1693 Result := False;
1694 {$else}
1695 Result := Screen.Width > 240;
1696 {$endif}
1697 end;
1698
1699
1700 {-------------------------------------------------------------------------------
1701 procedure AddToChangedMenus(Window: HWnd);
1702
1703 Adds Window to the list of windows which need to redraw the main menu.
1704 -------------------------------------------------------------------------------}
1705 procedure AddToChangedMenus(Window: HWnd);
1706 begin
1707 if ChangedMenus.IndexOf(Pointer(Window)) = -1 then // Window handle is not yet in the list
1708 ChangedMenus.Add(Pointer(Window));
1709 end;
1710
1711 {------------------------------------------------------------------------------
1712 Method: RedrawMenus
1713 Params: None
1714 Returns: Nothing
1715
1716 Redraws all changed menus
1717 ------------------------------------------------------------------------------}
1718 procedure RedrawMenus;
1719 var
1720 I: integer;
1721 begin
1722 for I := 0 to ChangedMenus.Count - 1 do
1723 DrawMenuBar(HWND(ChangedMenus[I]));
1724 ChangedMenus.Clear;
1725 end;
1726
1727 procedure UpdateWindowsVersion;
1728 {$ifdef WinCE}
1729 var
1730 versionInfo: OSVERSIONINFO;
1731 begin
1732 WindowsVersion := wince_other;
1733
1734 System.FillChar(versionInfo, sizeof(OSVERSIONINFO), #0);
1735 versionInfo.dwOSVersionInfoSize := sizeof(OSVERSIONINFO);
1736
1737 if GetVersionEx(@versionInfo) then
1738 begin
1739 case versionInfo.dwMajorVersion of
1740 1: WindowsVersion := wince_1;
1741 2: WindowsVersion := Wince_2;
1742 3: WindowsVersion := Wince_3;
1743 4: WindowsVersion := Wince_4;
1744 5:
1745 begin
1746 if versionInfo.dwMinorVersion = 2 then WindowsVersion := Wince_6
1747 else WindowsVersion := Wince_5;
1748 end;
1749 6: WindowsVersion := Wince_6;
1750 end;
1751 end;
1752 end;
1753 {$else}
1754 begin
1755 case Win32MajorVersion of
1756 0..3:;
1757 4: begin
1758 if Win32Platform = VER_PLATFORM_WIN32_NT
1759 then WindowsVersion := wvNT4
1760 else
1761 case Win32MinorVersion of
1762 10: WindowsVersion := wv98;
1763 90: WindowsVersion := wvME;
1764 else
1765 WindowsVersion :=wv95;
1766 end;
1767 end;
1768 5: begin
1769 case Win32MinorVersion of
1770 0: WindowsVersion := wv2000;
1771 1: WindowsVersion := wvXP;
1772 else
1773 // XP64 has also a 5.2 version
1774 // we could detect that based on arch and versioninfo.Producttype
1775 WindowsVersion := wvServer2003;
1776 end;
1777 end;
1778 6: begin
1779 case Win32MinorVersion of
1780 0: WindowsVersion := wvVista;
1781 1: WindowsVersion := wv7;
1782 else
1783 WindowsVersion := wvLater;
1784 end;
1785 end;
1786 else
1787 WindowsVersion := wvLater;
1788 end;
1789 end;
1790 {$endif}
1791
1792 initialization
1793 DefaultWindowInfo := TWindowInfo.Create;
1794 WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
1795 ChangedMenus := TList.Create;
1796 UpdateWindowsVersion();
1797
1798 finalization
1799 Windows.GlobalDeleteAtom(WindowInfoAtom);
1800 WindowInfoAtom := 0;
1801 ChangedMenus.Free;
1802 end.
1803