1
{ ------------------------------
3
------------------------------
5
Misc types and procedures for LCL-CustomDrawn-Windows
7
*****************************************************************************
9
* This file is part of the Lazarus Component Library (LCL) *
11
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
12
* for details about the copyright. *
14
* This program is distributed in the hope that it will be useful, *
15
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
16
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
18
*****************************************************************************
21
unit customdrawn_winproc;
28
Windows, CTypes, Classes, SysUtils,
30
LCLType, Interfacebase, LMessages, lclintf, LCLMessageGlue, LCLProc,
31
Controls, Forms, graphtype, Menus, IntfGraphics, lazcanvas,
36
MCHITTESTINFO = record
39
uHit : UINT; // out param
42
TMCMHitTestInfo = MCHITTESTINFO;
43
PMCMHitTestInfo = ^TMCMHitTestInfo;
45
// Window information snapshot
46
tagWINDOWINFO = record
52
dwWindowStatus: DWORD;
53
cxWindowBorders: UINT;
54
cyWindowBorders: UINT;
56
wCreatorVersion: WORD;
58
PTAGWINDOWINFO = ^tagWINDOWINFO;
61
{ lazarus win32 Interface definition for additional timer data needed to find the callback}
62
PWinCETimerInfo = ^TWinCETimerinfo;
63
TWinCETimerInfo = record
64
TimerID: UINT_PTR; // the windows timer ID for this timer
65
TimerFunc: TWSTimerProc; // owner function to handle timer
69
function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; cdecl; external KernelDLL name 'EnumDisplayMonitors';
70
function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; cdecl; external KernelDLL name 'GetMonitorInfo';
71
function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; cdecl; external KernelDLL name 'MonitorFromWindow';
72
function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromRect';
73
function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromPoint';
75
function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; stdcall; external 'user32.dll' name 'EnumDisplayMonitors';
76
function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; stdcall; external 'user32.dll' name 'GetMonitorInfoW';
77
function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromWindow';
78
function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromRect';
79
function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromPoint';
81
function GetWindowInfo(hwnd: HWND; pwi: PTAGWINDOWINFO): BOOL; stdcall; external 'user32.dll' name 'GetWindowInfo';
85
TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged);
87
PProcessEvent = ^TProcessEvent;
88
TProcessEvent = record
90
Handler: PEventHandler;
92
OnEvent: TChildExitEvent;
96
// FTimerData contains the currently running timers
97
FTimerData : TList; // list of PWin32Timerinfo
100
MouseDownPos: TPoint;
101
MouseDownWindow: HWND = 0;
102
MouseDownFocusWindow: HWND;
103
MouseDownFocusStatus: TMouseDownFocusStatus = mfNone;
104
ComboBoxHandleSizeWindow: HWND = 0;//just do not know the use yet
105
IgnoreNextCharWindow: HWND = 0; // ignore next WM_(SYS)CHAR message
106
OnClipBoardRequest: TClipboardRequestEvent = nil;
109
TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown);
111
TWindowInfo = class(TCDForm)
112
Overlay: HWND; // overlay, transparent window on top, used by designer
113
//PopupMenu: TPopupMenu;
115
ParentPanel: HWND; // if non-zero, is the tabsheet window, for the pagecontrol hack
117
StayOnTopList: TList; // a list of windows that were normalized when showing modal
119
MouseX, MouseY: word; // noticing spurious WM_MOUSEMOVE messages
122
BitmapWidth: integer;
123
BitmapHeight: integer;
124
BitmapDC, DCBitmapOld: HDC;
127
PStayOnTopWindowsInfo = ^TStayOnTopWindowsInfo;
128
TStayOnTopWindowsInfo = record
130
SystemTopAlso: Boolean;
131
StayOnTopList: TList;
155
//wvServer2003R2, // has the same major/minor as wvServer2003
157
//wvServer2008, // has the same major/minor as wvVista
163
function WM_To_String(WM_Message: Integer): string;
164
function WindowPosFlagsToString(Flags: UINT): string;
165
function ObjectToHWND(Const AObject: TObject): HWND;
167
function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
168
function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
169
procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
170
procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
171
function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
172
function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
175
function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP):TRawImageLineOrder;
177
function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
178
function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
179
function IsAlphaDC(ADC: HDC): Boolean;
181
function GetLastErrorText(AErrorCode: Cardinal): WideString;
183
function LCLControlSizeNeedsUpdate(Sender: TWinControl;
184
SendSizeMsgOnDiff: boolean): boolean;
186
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
187
function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean;
188
procedure LCLBoundsToWin32Bounds(Sender: TObject;
189
var Left, Top, Width, Height: Integer);
190
procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
191
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
193
function GetWindowInfo(AWindow: HWND): TWindowInfo;
195
procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
196
function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
197
function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
199
function GetFileVersion(FileName: string): dword;
201
procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
202
procedure RestoreStayOnTopFlags(AppHandle: HWND);
204
procedure AddToChangedMenus(Window: HWnd);
205
procedure RedrawMenus;
206
function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
207
function GetControlText(AHandle: HWND): string;
209
{ String functions that may be moved to the RTL in the future }
210
procedure WideStrCopy(Dest, Src: PWideChar);
211
function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
212
function WideStrCmp(W1, W2: PWideChar): Integer;
214
{ Automatic detection of platform }
215
function GetWinCEPlatform: TApplicationType;
216
function IsHiResMode: Boolean;
217
procedure UpdateWindowsVersion;
220
DefaultWindowInfo: TWindowInfo;
221
WindowInfoAtom: ATOM;
222
OverwriteCheck: Integer = 0;
223
ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn
225
WindowsVersion: TWindowsVersion = wvUnknown;
228
ClsName: array[0..6] of WideChar = ('W', 'i', 'n', 'd', 'o', 'w', #0);
229
ClsHintName: array[0..10] of WideChar = ('H', 'i', 'n', 't', 'W', 'i', 'n', 'd', 'o', 'w', #0);
236
InRemoveStayOnTopFlags: Integer = 0;
238
{------------------------------------------------------------------------------
239
Function: WM_To_String
240
Params: WM_Message - a WinDows message
241
Returns: A WinDows-message name
243
Converts a winDows message identIfier to a string
244
------------------------------------------------------------------------------}
245
function WM_To_String(WM_Message: Integer): string;
248
$0000: Result := 'WM_NULL';
249
$0001: Result := 'WM_CREATE';
250
$0002: Result := 'WM_DESTROY';
251
$0003: Result := 'WM_MOVE';
252
$0005: Result := 'WM_SIZE';
253
$0006: Result := 'WM_ACTIVATE';
254
$0007: Result := 'WM_SETFOCUS';
255
$0008: Result := 'WM_KILLFOCUS';
256
$000A: Result := 'WM_ENABLE';
257
$000B: Result := 'WM_SETREDRAW';
258
$000C: Result := 'WM_SETTEXT';
259
$000D: Result := 'WM_GETTEXT';
260
$000E: Result := 'WM_GETTEXTLENGTH';
261
$000F: Result := 'WM_PAINT';
262
$0010: Result := 'WM_CLOSE';
263
$0011: Result := 'WM_QUERYENDSESSION';
264
$0012: Result := 'WM_QUIT';
265
$0013: Result := 'WM_QUERYOPEN';
266
$0014: Result := 'WM_ERASEBKGND';
267
$0015: Result := 'WM_SYSCOLORCHANGE';
268
$0016: Result := 'WM_EndSESSION';
269
$0017: Result := 'WM_SYSTEMERROR';
270
$0018: Result := 'WM_SHOWWINDOW';
271
$0019: Result := 'WM_CTLCOLOR';
272
$001A: Result := 'WM_WININICHANGE or WM_SETTINGCHANGE';
273
$001B: Result := 'WM_DEVMODECHANGE';
274
$001C: Result := 'WM_ACTIVATEAPP';
275
$001D: Result := 'WM_FONTCHANGE';
276
$001E: Result := 'WM_TIMECHANGE';
277
$001F: Result := 'WM_CANCELMODE';
278
$0020: Result := 'WM_SETCURSOR';
279
$0021: Result := 'WM_MOUSEACTIVATE';
280
$0022: Result := 'WM_CHILDACTIVATE';
281
$0023: Result := 'WM_QUEUESYNC';
282
$0024: Result := 'WM_GETMINMAXINFO';
283
$0026: Result := 'WM_PAINTICON';
284
$0027: Result := 'WM_ICONERASEBKGND';
285
$0028: Result := 'WM_NEXTDLGCTL';
286
$002A: Result := 'WM_SPOOLERSTATUS';
287
$002B: Result := 'WM_DRAWITEM';
288
$002C: Result := 'WM_MEASUREITEM';
289
$002D: Result := 'WM_DELETEITEM';
290
$002E: Result := 'WM_VKEYTOITEM';
291
$002F: Result := 'WM_CHARTOITEM';
292
$0030: Result := 'WM_SETFONT';
293
$0031: Result := 'WM_GETFONT';
294
$0032: Result := 'WM_SETHOTKEY';
295
$0033: Result := 'WM_GETHOTKEY';
296
$0037: Result := 'WM_QUERYDRAGICON';
297
$0039: Result := 'WM_COMPAREITEM';
298
$003D: Result := 'WM_GETOBJECT';
299
$0041: Result := 'WM_COMPACTING';
300
$0044: Result := 'WM_COMMNOTIFY { obsolete in Win32}';
301
$0046: Result := 'WM_WINDOWPOSCHANGING';
302
$0047: Result := 'WM_WINDOWPOSCHANGED';
303
$0048: Result := 'WM_POWER';
304
$004A: Result := 'WM_COPYDATA';
305
$004B: Result := 'WM_CANCELJOURNAL';
306
$004E: Result := 'WM_NOTIFY';
307
$0050: Result := 'WM_INPUTLANGCHANGEREQUEST';
308
$0051: Result := 'WM_INPUTLANGCHANGE';
309
$0052: Result := 'WM_TCARD';
310
$0053: Result := 'WM_HELP';
311
$0054: Result := 'WM_USERCHANGED';
312
$0055: Result := 'WM_NOTIFYFORMAT';
313
$007B: Result := 'WM_CONTEXTMENU';
314
$007C: Result := 'WM_STYLECHANGING';
315
$007D: Result := 'WM_STYLECHANGED';
316
$007E: Result := 'WM_DISPLAYCHANGE';
317
$007F: Result := 'WM_GETICON';
318
$0080: Result := 'WM_SETICON';
319
$0081: Result := 'WM_NCCREATE';
320
$0082: Result := 'WM_NCDESTROY';
321
$0083: Result := 'WM_NCCALCSIZE';
322
$0084: Result := 'WM_NCHITTEST';
323
$0085: Result := 'WM_NCPAINT';
324
$0086: Result := 'WM_NCACTIVATE';
325
$0087: Result := 'WM_GETDLGCODE';
326
$00A0: Result := 'WM_NCMOUSEMOVE';
327
$00A1: Result := 'WM_NCLBUTTONDOWN';
328
$00A2: Result := 'WM_NCLBUTTONUP';
329
$00A3: Result := 'WM_NCLBUTTONDBLCLK';
330
$00A4: Result := 'WM_NCRBUTTONDOWN';
331
$00A5: Result := 'WM_NCRBUTTONUP';
332
$00A6: Result := 'WM_NCRBUTTONDBLCLK';
333
$00A7: Result := 'WM_NCMBUTTONDOWN';
334
$00A8: Result := 'WM_NCMBUTTONUP';
335
$00A9: Result := 'WM_NCMBUTTONDBLCLK';
336
$0100: Result := 'WM_KEYFIRST or WM_KEYDOWN';
337
$0101: Result := 'WM_KEYUP';
338
$0102: Result := 'WM_CHAR';
339
$0103: Result := 'WM_DEADCHAR';
340
$0104: Result := 'WM_SYSKEYDOWN';
341
$0105: Result := 'WM_SYSKEYUP';
342
$0106: Result := 'WM_SYSCHAR';
343
$0107: Result := 'WM_SYSDEADCHAR';
344
$0108: Result := 'WM_KEYLAST';
345
$010D: Result := 'WM_IME_STARTCOMPOSITION';
346
$010E: Result := 'WM_IME_ENDCOMPOSITION';
347
$010F: Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST';
348
$0110: Result := 'WM_INITDIALOG';
349
$0111: Result := 'WM_COMMAND';
350
$0112: Result := 'WM_SYSCOMMAND';
351
$0113: Result := 'WM_TIMER';
352
$0114: Result := 'WM_HSCROLL';
353
$0115: Result := 'WM_VSCROLL';
354
$0116: Result := 'WM_INITMENU';
355
$0117: Result := 'WM_INITMENUPOPUP';
356
$011F: Result := 'WM_MENUSELECT';
357
$0120: Result := 'WM_MENUCHAR';
358
$0121: Result := 'WM_ENTERIDLE';
359
$0122: Result := 'WM_MENURBUTTONUP';
360
$0123: Result := 'WM_MENUDRAG';
361
$0124: Result := 'WM_MENUGETOBJECT';
362
$0125: Result := 'WM_UNINITMENUPOPUP';
363
$0126: Result := 'WM_MENUCOMMAND';
364
$0132: Result := 'WM_CTLCOLORMSGBOX';
365
$0133: Result := 'WM_CTLCOLOREDIT';
366
$0134: Result := 'WM_CTLCOLORLISTBOX';
367
$0135: Result := 'WM_CTLCOLORBTN';
368
$0136: Result := 'WM_CTLCOLORDLG';
369
$0137: Result := 'WM_CTLCOLORSCROLLBAR';
370
$0138: Result := 'WM_CTLCOLORSTATIC';
371
$0200: Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE';
372
$0201: Result := 'WM_LBUTTONDOWN';
373
$0202: Result := 'WM_LBUTTONUP';
374
$0203: Result := 'WM_LBUTTONDBLCLK';
375
$0204: Result := 'WM_RBUTTONDOWN';
376
$0205: Result := 'WM_RBUTTONUP';
377
$0206: Result := 'WM_RBUTTONDBLCLK';
378
$0207: Result := 'WM_MBUTTONDOWN';
379
$0208: Result := 'WM_MBUTTONUP';
380
$0209: Result := 'WM_MBUTTONDBLCLK';
381
$020A: Result := 'WM_MOUSEWHEEL or WM_MOUSELAST';
382
$0210: Result := 'WM_PARENTNOTIFY';
383
$0211: Result := 'WM_ENTERMENULOOP';
384
$0212: Result := 'WM_EXITMENULOOP';
385
$0213: Result := 'WM_NEXTMENU';
386
$0214: Result := 'WM_SIZING';
387
$0215: Result := 'WM_CAPTURECHANGED';
388
$0216: Result := 'WM_MOVING';
389
$0218: Result := 'WM_POWERBROADCAST';
390
$0219: Result := 'WM_DEVICECHANGE';
391
$0220: Result := 'WM_MDICREATE';
392
$0221: Result := 'WM_MDIDESTROY';
393
$0222: Result := 'WM_MDIACTIVATE';
394
$0223: Result := 'WM_MDIRESTORE';
395
$0224: Result := 'WM_MDINEXT';
396
$0225: Result := 'WM_MDIMAXIMIZE';
397
$0226: Result := 'WM_MDITILE';
398
$0227: Result := 'WM_MDICASCADE';
399
$0228: Result := 'WM_MDIICONARRANGE';
400
$0229: Result := 'WM_MDIGETACTIVE';
401
$0230: Result := 'WM_MDISETMENU';
402
$0231: Result := 'WM_ENTERSIZEMOVE';
403
$0232: Result := 'WM_EXITSIZEMOVE';
404
$0233: Result := 'WM_DROPFILES';
405
$0234: Result := 'WM_MDIREFRESHMENU';
406
$0281: Result := 'WM_IME_SETCONTEXT';
407
$0282: Result := 'WM_IME_NOTIFY';
408
$0283: Result := 'WM_IME_CONTROL';
409
$0284: Result := 'WM_IME_COMPOSITIONFULL';
410
$0285: Result := 'WM_IME_SELECT';
411
$0286: Result := 'WM_IME_CHAR';
412
$0288: Result := 'WM_IME_REQUEST';
413
$0290: Result := 'WM_IME_KEYDOWN';
414
$0291: Result := 'WM_IME_KEYUP';
415
$02A1: Result := 'WM_MOUSEHOVER';
416
$02A3: Result := 'WM_MOUSELEAVE';
417
$0300: Result := 'WM_CUT';
418
$0301: Result := 'WM_COPY';
419
$0302: Result := 'WM_PASTE';
420
$0303: Result := 'WM_CLEAR';
421
$0304: Result := 'WM_UNDO';
422
$0305: Result := 'WM_RENDERFORMAT';
423
$0306: Result := 'WM_RENDERALLFORMATS';
424
$0307: Result := 'WM_DESTROYCLIPBOARD';
425
$0308: Result := 'WM_DRAWCLIPBOARD';
426
$0309: Result := 'WM_PAINTCLIPBOARD';
427
$030A: Result := 'WM_VSCROLLCLIPBOARD';
428
$030B: Result := 'WM_SIZECLIPBOARD';
429
$030C: Result := 'WM_ASKCBFORMATNAME';
430
$030D: Result := 'WM_CHANGECBCHAIN';
431
$030E: Result := 'WM_HSCROLLCLIPBOARD';
432
$030F: Result := 'WM_QUERYNEWPALETTE';
433
$0310: Result := 'WM_PALETTEISCHANGING';
434
$0311: Result := 'WM_PALETTECHANGED';
435
$0312: Result := 'WM_HOTKEY';
436
$0317: Result := 'WM_PRINT';
437
$0318: Result := 'WM_PRINTCLIENT';
438
$0358: Result := 'WM_HANDHELDFIRST';
439
$035F: Result := 'WM_HANDHELDLAST';
440
$0380: Result := 'WM_PENWINFIRST';
441
$038F: Result := 'WM_PENWINLAST';
442
$0390: Result := 'WM_COALESCE_FIRST';
443
$039F: Result := 'WM_COALESCE_LAST';
444
$03E0: Result := 'WM_DDE_FIRST or WM_DDE_INITIATE';
445
$03E1: Result := 'WM_DDE_TERMINATE';
446
$03E2: Result := 'WM_DDE_ADVISE';
447
$03E3: Result := 'WM_DDE_UNADVISE';
448
$03E4: Result := 'WM_DDE_ACK';
449
$03E5: Result := 'WM_DDE_DATA';
450
$03E6: Result := 'WM_DDE_REQUEST';
451
$03E7: Result := 'WM_DDE_POKE';
452
$03E8: Result := 'WM_DDE_EXECUTE or WM_DDE_LAST';
453
$0400: Result := 'WM_USER';
454
$8000: Result := 'WM_APP';
456
Result := 'Unknown(' + IntToStr(WM_Message) + ')';
460
function WindowPosFlagsToString(Flags: UINT): string;
465
if (Flags and SWP_DRAWFRAME) <> 0 then
466
FlagsStr := FlagsStr + '|SWP_DRAWFRAME';
467
if (Flags and SWP_HIDEWINDOW) <> 0 then
468
FlagsStr := FlagsStr + '|SWP_HIDEWINDOW';
469
if (Flags and SWP_NOACTIVATE) <> 0 then
470
FlagsStr := FlagsStr + '|SWP_NOACTIVATE';
471
if (Flags and SWP_NOCOPYBITS) <> 0 then
472
FlagsStr := FlagsStr + '|SWP_NOCOPYBITS';
473
if (Flags and SWP_NOMOVE) <> 0 then
474
FlagsStr := FlagsStr + '|SWP_NOMOVE';
475
if (Flags and SWP_NOOWNERZORDER) <> 0 then
476
FlagsStr := FlagsStr + '|SWP_NOOWNERZORDER';
477
if (Flags and SWP_NOREDRAW) <> 0 then
478
FlagsStr := FlagsStr + '|SWP_NOREDRAW';
479
if (Flags and SWP_NOSENDCHANGING) <> 0 then
480
FlagsStr := FlagsStr + '|SWP_NOSENDCHANGING';
481
if (Flags and SWP_NOSIZE) <> 0 then
482
FlagsStr := FlagsStr + '|SWP_NOSIZE';
483
if (Flags and SWP_NOZORDER) <> 0 then
484
FlagsStr := FlagsStr + '|SWP_NOZORDER';
485
if (Flags and SWP_SHOWWINDOW) <> 0 then
486
FlagsStr := FlagsStr + '|SWP_SHOWWINDOW';
487
if Length(FlagsStr) > 0 then
488
FlagsStr := Copy(FlagsStr, 2, Length(FlagsStr)-1);
492
{------------------------------------------------------------------------------
493
Procedure: GetWin32KeyInfo
494
Params: Event - Requested info
495
KeyCode - the ASCII key code of the eventkey
496
VirtualKey - the virtual key code of the eventkey
497
SysKey - True If the key is a syskey
498
ExtEnded - True If the key is an extended key
499
Toggle - True If the key is a toggle key and its value is on
502
GetWin32KeyInfo returns information about the given key event
503
------------------------------------------------------------------------------}
505
procedure GetWin32KeyInfo(const Event: Integer; var KeyCode, VirtualKey: Integer; var SysKey, Extended, Toggle: Boolean);
509
//DebugLn('TRACE:Using function GetWin32KeyInfo which isn''t implemented yet');
510
KeyCode := Word(Event);
511
VirtualKey := MapVirtualKey(KeyCode, MVK_UNIFY_SIDES);
512
SysKey := (VirtualKey = VK_SHIFT) Or (VirtualKey = VK_CONTROL) Or (VirtualKey = VK_MENU);
513
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);
514
Toggle := Lo(GetKeyState(VirtualKey)) = 1;
518
{------------------------------------------------------------------------------
519
Function: ObjectToHWND
520
Params: AObject - An LCL Object
521
Returns: The Window handle of the given object
523
Returns the Window handle of the given object, 0 if no object available
524
------------------------------------------------------------------------------}
525
function ObjectToHWND(Const AObject: TObject): HWND;
530
If not assigned(AObject) Then
532
Assert (False, 'TRACE:[ObjectToHWND] Object not assigned');
534
Else If (AObject Is TWinControl) Then
536
If TWinControl(AObject).HandleAllocated Then
537
Handle := TWinControl(AObject).Handle
539
Else If (AObject Is TMenuItem) Then
541
If TMenuItem(AObject).HandleAllocated Then
542
Handle := TMenuItem(AObject).Handle
544
Else If (AObject Is TMenu) Then
546
If TMenu(AObject).HandleAllocated Then
547
Handle := TMenu(AObject).Items.Handle
549
// Else If (AObject Is TCommonDialog) Then
551
// {If TCommonDialog(AObject).HandleAllocated Then }
552
// Handle := TCommonDialog(AObject).Handle
556
//DebugLn(Format('Trace:[ObjectToHWND] Message received With unhandled class-type <%s>', [AObject.ClassName]));
560
Assert (False, 'Trace:[ObjectToHWND]****** Warning: handle = 0 *******');
563
function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
565
Result := ((nWidth * nBitsPerPixel + 31) and (not 31) ) div 8;
568
procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
570
case ADesc.BitsPerPixel of
573
// palette mode, no offsets
574
ADesc.Format := ricfGray;
575
ADesc.RedPrec := ADesc.BitsPerPixel;
576
ADesc.GreenPrec := 0;
579
ADesc.GreenShift := 0;
580
ADesc.BlueShift := 0;
585
//roozbeh all changed from 5-5-5 to 5-6-5
587
ADesc.GreenPrec := 6;
589
ADesc.RedShift := 11;
590
ADesc.GreenShift := 5;
591
ADesc.BlueShift := 0;
598
ADesc.GreenPrec := 8;
600
ADesc.RedShift := 16;
601
ADesc.GreenShift := 8;
602
ADesc.BlueShift := 0;
605
// 8-8-8-8 mode, high byte can be native alpha or custom 1bit maskalpha
606
ADesc.AlphaPrec := 8;
608
ADesc.GreenPrec := 8;
610
ADesc.AlphaShift := 24;
611
ADesc.RedShift := 16;
612
ADesc.GreenShift := 8;
613
ADesc.BlueShift := 0;
619
procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
623
ADesc.Format := ricfRGBA;
625
ADesc.Depth := ABitmapInfo.bmBitsPixel; // used bits per pixel
626
ADesc.Width := ABitmapInfo.bmWidth;
627
ADesc.Height := ABitmapInfo.bmHeight;
628
ADesc.BitOrder := riboReversedBits;
629
ADesc.ByteOrder := riboLSBFirst;
630
ADesc.LineOrder := riloTopToBottom;
631
ADesc.BitsPerPixel := ABitmapInfo.bmBitsPixel; // bits per pixel. can be greater than Depth.
632
ADesc.LineEnd := rileDWordBoundary;
634
if ABitmapInfo.bmBitsPixel <= 8
636
// each pixel is an index in the palette
638
ADesc.PaletteColorCount := 0;
640
else ADesc.PaletteColorCount := 0;
642
FillRawImageDescriptionColors(ADesc);
644
ADesc.MaskBitsPerPixel := 1;
645
ADesc.MaskShift := 0;
646
ADesc.MaskLineEnd := rileWordBoundary; // CreateBitmap requires word boundary
647
ADesc.MaskBitOrder := riboReversedBits;
650
function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean;
652
WinDIB: Windows.TDIBSection;
653
WinBmp: Windows.TBitmap absolute WinDIB.dsBm;
658
FillChar(WinDIB, SizeOf(WinDIB), 0);
659
ASize := Windows.GetObject(ABitmap, SizeOf(WinDIB), @WinDIB);
663
//DbgDumpBitmap(ABitmap, 'FromBitmap - Image');
664
//DbgDumpBitmap(AMask, 'FromMask - Mask');
666
FillRawImageDescription(WinBmp, ARawImage.Description);
667
// if it is not DIB then alpha in bitmaps is not supported => use 0 alpha prec
668
if ASize < SizeOf(WinDIB) then
669
ARawImage.Description.AlphaPrec := 0;
673
R := Rect(0, 0, WinBmp.bmWidth, WinBmp.bmHeight);
677
if R.Top > WinBmp.bmHeight then
678
R.Top := WinBmp.bmHeight;
679
if R.Bottom > WinBmp.bmHeight then
680
R.Bottom := WinBmp.bmHeight;
681
if R.Left > WinBmp.bmWidth then
682
R.Left := WinBmp.bmWidth;
683
if R.Right > WinBmp.bmWidth then
684
R.Right := WinBmp.bmWidth;
687
ARawImage.Description.Width := R.Right - R.Left;
688
ARawImage.Description.Height := R.Bottom - R.Top;
691
Result := GetBitmapBytes(WinBmp, ABitmap, R, ARawImage.Description.LineEnd, ARawImage.Description.LineOrder, ARawImage.Data, ARawImage.DataSize);
696
if Windows.GetObject(AMask, SizeOf(WinBmp), @WinBmp) = 0
699
Result := GetBitmapBytes(WinBmp, AMask, R, ARawImage.Description.MaskLineEnd, ARawImage.Description.LineOrder, ARawImage.Mask, ARawImage.MaskSize);
702
ARawImage.Description.MaskBitsPerPixel := 0;
706
{------------------------------------------------------------------------------
707
Function: RawImage_CreateBitmaps
711
ASkipMask: When set there is no mask created
714
------------------------------------------------------------------------------}
716
function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
718
ADesc: TRawImageDescription absolute ARawImage.Description;
726
if not ((ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary)) then
728
DC := Windows.GetDC(0);
730
ABitmap := CreateDIBSectionFromDescription(DC, ADesc, BitsPtr);
731
//DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image');
732
Windows.ReleaseDC(0, DC);
734
Result := ABitmap <> 0;
735
if not Result then Exit;
736
if BitsPtr = nil then Exit;
738
// copy the image data
739
DataSize := BytesPerLine(ADesc.Width, ADesc.BitsPerPixel) * ADesc.Height;
740
if DataSize > ARawImage.DataSize
741
then DataSize := ARawImage.DataSize;
742
Move(ARawImage.Data^, BitsPtr^, DataSize);
745
ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data);
747
if ASkipMask then Exit(True);
749
AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask);
750
//DbgDumpBitmap(ABitmap, 'CreateBitmaps - Mask');
751
Result := AMask <> 0;
754
function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean;
756
ADesc: TRawImageDescription absolute ARawImage.Description;
758
function DoBitmap: Boolean;
762
Header: Windows.TBitmapInfoHeader;
763
Colors: array[0..1] of Cardinal; // reserve extra color for mono bitmaps
765
DstLinePtr, SrcLinePtr: PByte;
766
SrcPixelPtr, DstPixelPtr: PByte;
767
DstLineSize, SrcLineSize: PtrUInt;
769
Ridx, Gidx, Bidx, Aidx, Align, SrcBytes, DstBpp: Byte;
771
if (ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary)
773
// default BW, word aligned bitmap
774
ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data);
778
// for 24 bits images, BPP can be 24 or 32
779
// 32 shouldn't be use since we don't fill the alpha channel
783
else DstBpp := ADesc.BitsPerPixel;
785
FillChar(Info, SizeOf(Info), 0);
786
Info.Header.biSize := SizeOf(Info.Header);
787
Info.Header.biWidth := ADesc.Width;
788
if ADesc.LineOrder = riloTopToBottom
789
then Info.Header.biHeight := -ADesc.Height // create top to bottom
790
else Info.Header.biHeight := ADesc.Height; // create bottom to top
791
Info.Header.biPlanes := 1;
792
Info.Header.biBitCount := DstBpp;
793
Info.Header.biCompression := BI_RGB;
794
{Info.Header.biSizeImage := 0;}
795
{ first color is black, second color is white, for monochrome bitmap }
796
Info.Colors[1] := $FFFFFFFF;
798
DC := Windows.GetDC(0);
799
// Use createDIBSection, since only devicedepth bitmaps can be selected into a DC
800
// when they are created with createDIBitmap
801
// ABitmap := Windows.CreateDIBitmap(DC, Info.Header, CBM_INIT, ARawImage.Data, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS);
802
ABitmap := Windows.CreateDIBSection(DC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, DstLinePtr, 0, 0);
803
Windows.ReleaseDC(0, DC);
807
DebugLn('Windows.CreateDIBSection returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError));
810
if DstLinePtr = nil then Exit(False);
812
DstLineSize := Windows.MulDiv(DstBpp, ADesc.Width, 8);
814
Align := DstLineSize and 3;
816
then Inc(DstLineSize, 4 - Align);
818
SrcLinePtr := ARawImage.Data;
819
SrcLineSize := ADesc.BytesPerLine;
821
// copy the image data
824
// check if a pixel copy is needed
825
// 1) Windows uses alpha channel in 32 bpp modes, despite documentation statement that it is ignored. Tested under Windows XP SP3
826
// Wine also relies on this undocumented behaviour!
827
// So, we need to cut unused A-channel, otherwise we would get black image
829
// 2) incompatible channel order
830
ADesc.GetRGBIndices(Ridx, Gidx, Bidx, Aidx);
832
if ((ADesc.BitsPerPixel = 32) and (ADesc.Depth = 24))
833
or (Bidx <> 0) or (Gidx <> 1) or (Ridx <> 2)
836
SrcBytes := ADesc.BitsPerPixel div 8;
838
for y := 0 to ADesc.Height - 1 do
840
DstPixelPtr := DstLinePtr;
841
SrcPixelPtr := SrcLinePtr;
842
for x := 0 to ADesc.Width - 1 do
844
DstPixelPtr[0] := SrcPixelPtr[Bidx];
845
DstPixelPtr[1] := SrcPixelPtr[Gidx];
846
DstPixelPtr[2] := SrcPixelPtr[Ridx];
848
Inc(DstPixelPtr, 3); //move to the next dest RGB triple
849
Inc(SrcPixelPtr, SrcBytes);
852
Inc(DstLinePtr, DstLineSize);
853
Inc(SrcLinePtr, SrcLineSize);
860
// no pixelcopy needed
861
// check if we can move using one call
862
if ADesc.LineEnd = rileDWordBoundary
864
Move(SrcLinePtr^, DstLinePtr^, DstLineSize * ADesc.Height);
868
//Can't use just one move, as different alignment
869
for y := 0 to ADesc.Height - 1 do
871
Move(SrcLinePtr^, DstLinePtr^, DstLineSize);
872
Inc(DstLinePtr, DstLineSize);
873
Inc(SrcLinePtr, SrcLineSize);
882
if not Result then Exit;
884
//DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image');
885
if ASkipMask then Exit;
887
AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask);
889
DebugLn('Windows.CreateBitmap returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError));
890
Result := AMask <> 0;
891
//DbgDumpBitmap(AMask, 'CreateBitmaps - Mask');
895
function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
896
function GetMask(APrec, AShift: Byte): Cardinal;
898
Result := ($FFFFFFFF shr (32-APrec)) shl AShift;
903
Header: Windows.TBitmapInfoHeader;
904
Colors: array[0..3] of Cardinal; // reserve extra color for colormasks
907
FillChar(Info, sizeof(Info), 0);
908
Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader);
909
Info.Header.biWidth := ADesc.Width;
910
Info.Header.biHeight := -ADesc.Height;
911
Info.Header.biPlanes := 1;
912
Info.Header.biBitCount := ADesc.BitsPerPixel;
913
// TODO: palette support
914
Info.Header.biClrUsed := 0;
915
Info.Header.biClrImportant := 0;
916
Info.Header.biSizeImage := BytesPerLine(Info.Header.biWidth, Info.Header.biBitCount) * ADesc.Height;
917
// CE only supports bitfields
918
if ADesc.BitsPerPixel > 8
919
then Info.Header.biCompression := BI_BITFIELDS
920
else Info.Header.biCompression := BI_RGB;
922
if ADesc.BitsPerPixel = 1
924
// mono bitmap: first color is black, second is white
925
Info.Colors[1] := $FFFFFFFF;
928
// when 24bpp, CE only supports B8G8R8 encoding
929
// TODO: check the description
930
Info.Colors[0] := GetMask(ADesc.RedPrec, ADesc.RedShift);
931
Info.Colors[1] := GetMask(ADesc.GreenPrec, ADesc.GreenShift);
932
Info.Colors[2] := GetMask(ADesc.BluePrec, ADesc.BlueShift);
935
// Use createDIBSection, since only devicedepth bitmaps can be selected into a DC
936
// when they are created with createDIBitmap
937
Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, ABitsPtr, 0, 0);
939
//DbgDumpBitmap(Result, 'CreateDIBSectionFromDescription - Image');
942
function CreateDIBSectionFromDDB(ASource: HBitmap; out ABitsPtr: Pointer): HBitmap;
944
ADC, SrcDC, DstDC: HDC;
945
ADesc: TRawImageDescription;
946
SrcOldBm, DstOldBm: HBitmap;
950
// get source bitmap description
951
if not RawImage_DescriptionFromBitmap(ASource, ADesc) then
954
// create apropriate dib section
956
Result := CreateDIBSectionFromDescription(ADC, ADesc, ABitsPtr);
962
// copy source bitmap into destination
963
SrcDC := CreateCompatibleDC(0);
964
SrcOldBm := SelectObject(SrcDC, ASource);
965
DstDC := CreateCompatibleDC(0);
966
DstOldBm := SelectObject(DstDC, Result);
967
Windows.BitBlt(DstDC, 0, 0, ADesc.Width, ADesc.Height, SrcDC, 0, 0, SRCCOPY);
968
SelectObject(SrcDC, SrcOldBm);
969
SelectObject(DstDC, DstOldBm);
975
function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP): TRawImageLineOrder;
976
procedure DbgLog(const AFunc: String);
978
DebugLn('GetBitmapOrder - GetDIBits ', AFunc, ' failed: ', GetLastErrorText(Windows.GetLastError));
982
SrcPixel: PCardinal absolute AWinBmp.bmBits;
983
OrgPixel, TstPixel: Cardinal;
987
Header: Windows.TBitmapInfoHeader;
988
Colors: array[Byte] of Cardinal; // reserve extra color for colormasks
991
FullScanLine: Boolean; // win9x requires a full scanline to be retrieved
992
// others won't fail when one pixel is requested
994
if AWinBmp.bmBits = nil
996
// no DIBsection so always bottom-up
997
Exit(riloBottomToTop);
1000
// try to figure out the orientation of the given bitmap.
1001
// Unfortunately MS doesn't provide a direct function for this.
1002
// So modify the first pixel to see if it changes. This pixel is always part
1003
// of the first scanline of the given bitmap.
1004
// When we request the data through GetDIBits as bottom-up, windows adjusts
1005
// the data when it is a top-down. So if the pixel doesn't change the bitmap
1006
// was internally a top-down image.
1008
FullScanLine := Win32Platform = VER_PLATFORM_WIN32_WINDOWS;
1010
then ScanLine := GetMem(AWinBmp.bmWidthBytes);
1012
FillChar(Info.Header, sizeof(Windows.TBitmapInfoHeader), 0);
1013
Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader);
1014
DC := Windows.GetDC(0);
1015
if Windows.GetDIBits(DC, ABitmap, 0, 1, nil, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1019
Windows.ReleaseDC(0, DC);
1020
Exit(riloBottomToTop);
1023
// Get only 1 pixel (or full scanline for win9x)
1027
if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1028
then DbgLog('OrgPixel')
1029
else OrgPixel := PCardinal(ScanLine)^;
1032
Info.Header.biWidth := 1;
1033
if Windows.GetDIBits(DC, ABitmap, 0, 1, @OrgPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1034
then DbgLog('OrgPixel');
1038
SrcPixel^ := not SrcPixel^;
1044
if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1045
then DbgLog('TstPixel')
1046
else TstPixel := PCardinal(ScanLine)^;
1049
if Windows.GetDIBits(DC, ABitmap, 0, 1, @TstPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0
1050
then DbgLog('TstPixel');
1053
if OrgPixel = TstPixel
1054
then Result := riloTopToBottom
1055
else Result := riloBottomToTop;
1057
// restore pixel & cleanup
1058
SrcPixel^ := not SrcPixel^;
1059
Windows.ReleaseDC(0, DC);
1061
then FreeMem(Scanline);
1066
//function GetBitmapBytes(ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; var AData: Pointer; var ADataSize: PtrUInt): Boolean;
1067
function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
1069
Section: Windows.TDIBSection;
1074
// first try if the bitmap is created as section
1075
if (Windows.GetObject(ABitmap, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
1077
with Section.dsBm do
1078
Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
1082
// bitmap is not a section, retrieve only bitmap
1083
if Windows.GetObject(ABitmap, SizeOf(Section.dsBm), @Section) = 0
1086
DIBCopy := CreateDIBSectionFromDDB(ABitmap, DIBData);
1089
if (Windows.GetObject(DIBCopy, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
1091
with Section.dsBm do
1092
Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
1095
DeleteObject(DIBCopy);
1100
function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean;
1104
Header: Windows.TBitmapInfoHeader;
1105
Colors: array[Byte] of TRGBQuad; // reserve extra colors for palette (256 max)
1111
SrcLineBytes: Cardinal;
1112
SrcLineOrder: TRawImageLineOrder;
1115
SrcLineOrder := GetBitmapOrder(AWinBmp, ABitmap);
1116
SrcLineBytes := (AWinBmp.bmWidthBytes + 3) and not 3;
1118
if AWinBmp.bmBits <> nil
1120
// this is bitmapsection data :) we can just copy the bits
1122
// We cannot trust windows with bmWidthBytes. Use SrcLineBytes which takes
1123
// DWORD alignment into consideration
1125
Result := CopyImageData(bmWidth, bmHeight, SrcLineBytes, bmBitsPixel, bmBits, ARect, SrcLineOrder, ALineOrder, ALineEnd, AData, ADataSize);
1129
// retrieve the data though GetDIBits
1131
// initialize bitmapinfo structure
1132
Info.Header.biSize := sizeof(Info.Header);
1133
Info.Header.biPlanes := 1;
1134
Info.Header.biBitCount := AWinBmp.bmBitsPixel;
1135
Info.Header.biCompression := BI_RGB;
1136
Info.Header.biSizeImage := 0;
1138
Info.Header.biWidth := AWinBmp.bmWidth;
1139
H := ARect.Bottom - ARect.Top;
1140
// request a top-down DIB
1141
if AWinBmp.bmHeight > 0
1143
Info.Header.biHeight := -AWinBmp.bmHeight;
1144
StartScan := AWinBmp.bmHeight - ARect.Bottom;
1147
Info.Header.biHeight := AWinBmp.bmHeight;
1148
StartScan := ARect.Top;
1158
SrcSize := SrcLineBytes * H;
1159
GetMem(SrcData, SrcSize);
1161
DC := Windows.GetDC(0);
1162
Result := Windows.GetDIBits(DC, ABitmap, StartScan, H, SrcData, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) <> 0;
1163
Windows.ReleaseDC(0, DC);
1165
// since we only got the needed scanlines, adjust top and bottom
1166
R.Left := ARect.Left;
1168
R.Right := ARect.Right;
1172
Result := Result and CopyImageData(biWidth, H, SrcLineBytes, biBitCount, SrcData, R, riloTopToBottom, ALineOrder, ALineEnd, AData, ADataSize);
1178
function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
1180
Info: Windows.BITMAP;
1182
FillChar(Info, SizeOf(Info), 0);
1183
Result := (GetObject(ABitmap, SizeOf(Info), @Info) <> 0)
1184
and (Info.bmBitsPixel = 32);
1187
function IsAlphaDC(ADC: HDC): Boolean;
1189
Result := (GetObjectType(ADC) = OBJ_MEMDC)
1190
and IsAlphaBitmap(GetCurrentObject(ADC, OBJ_BITMAP));
1193
function GetLastErrorText(AErrorCode: Cardinal): WideString;
1199
r := Windows.FormatMessage(
1200
FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
1201
nil, AErrorCode, LANG_NEUTRAL, @tmp, 0, nil);
1203
if r = 0 then Exit('');
1206
SetLength(Result, Length(Result)-2);
1209
then LocalFree(HLOCAL(tmp));
1212
(***********************************************************************
1213
Widget member Functions
1214
************************************************************************)
1216
{-------------------------------------------------------------------------------
1217
function LCLBoundsNeedsUpdate(Sender: TWinControl;
1218
SendSizeMsgOnDiff: boolean): boolean;
1220
Returns true if LCL bounds and win32 bounds differ for the control.
1221
-------------------------------------------------------------------------------}
1222
function LCLControlSizeNeedsUpdate(Sender: TWinControl;
1223
SendSizeMsgOnDiff: boolean): boolean;
1227
IntfWidth, IntfHeight: integer;
1230
Window:= Sender.Handle;
1231
LCLIntf.GetWindowSize(Window, IntfWidth, IntfHeight);
1232
if (Sender.Width = IntfWidth)
1233
and (Sender.Height = IntfHeight)
1234
and (not Sender.ClientRectNeedsInterfaceUpdate) then
1237
if SendSizeMsgOnDiff then
1239
//writeln('LCLBoundsNeedsUpdate B ',TheWinControl.Name,':',TheWinControl.ClassName,' Sending WM_SIZE');
1240
Sender.InvalidateClientRectCache(true);
1241
// send message directly to LCL, some controls not subclassed -> message
1242
// never reaches LCL
1246
SizeType := SIZE_RESTORED or Size_SourceIsInterface;
1248
Height := IntfHeight;
1250
DeliverMessage(Sender, LMessage);
1254
{-------------------------------------------------------------------------------
1255
function GetLCLClientOriginOffset(Sender: TObject;
1256
var LeftOffset, TopOffset: integer): boolean;
1258
Returns the difference between the client origin of a win32 handle
1259
and the definition of the LCL counterpart.
1261
TGroupBox's client area is the area inside the groupbox frame.
1262
Hence, the LeftOffset is the frame width and the TopOffset is the caption
1264
-------------------------------------------------------------------------------}
1265
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
1270
TheWinControl: TWinControl;
1275
if (Sender = nil) or (not (Sender is TWinControl)) then exit;
1276
TheWinControl:=TWinControl(Sender);
1277
FillChar(ORect, SizeOf(ORect), 0);
1278
if not TheWinControl.HandleAllocated then exit;
1279
Handle := TheWinControl.Handle;
1280
if TheWinControl is TScrollingWinControl then
1281
with TScrollingWinControl(TheWinControl) do
1283
if HorzScrollBar <> nil then
1285
// left and right bounds are shifted by scroll position
1286
ORect.Left := -HorzScrollBar.Position;
1287
ORect.Right := -HorzScrollBar.Position;
1289
if VertScrollBar <> nil then
1291
// top and bottom bounds are shifted by scroll position
1292
ORect.Top := -VertScrollBar.Position;
1293
ORect.Bottom := -VertScrollBar.Position;
1297
{$ifdef DEBUG_WINDOW_ORG}
1299
Format('GetLCLClientBoundsOffset Name=%s OLeft=%d OTop=%d ORight=%d OBottom=%d',
1300
[TheWinControl.Name, ORect.Left, ORect.Top, ORect.Right, ORect.Bottom]));
1306
function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean;
1308
OwnerObject: TObject;
1310
OwnerObject := TWindowInfo(Handle).LCLForm;
1311
Result:=GetLCLClientBoundsOffset(OwnerObject, Rect);
1314
procedure LCLBoundsToWin32Bounds(Sender: TObject;
1315
var Left, Top, Width, Height: Integer);
1319
if (Sender=nil) or (not (Sender is TWinControl)) then exit;
1320
if not GetLCLClientBoundsOffset(TWinControl(Sender).Parent, ORect) then exit;
1321
inc(Left, ORect.Left);
1322
inc(Top, ORect.Top);
1325
procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
1326
{$NOTE Should be moved to WSWin32Forms, if the windowproc is splitted}
1328
SizeRect: Windows.RECT;
1329
BorderStyle: TFormBorderStyle;
1338
BorderStyle := Form.BorderStyle;
1339
Windows.AdjustWindowRectEx(@SizeRect, BorderStyleToWinAPIFlags(
1340
BorderStyle), false, BorderStyleToWinAPIFlagsEx(Form, BorderStyle));
1341
AWidth := SizeRect.Right - SizeRect.Left;
1342
AHeight := SizeRect.Bottom - SizeRect.Top;
1345
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
1347
parRect, winRect: Windows.TRect;
1349
Windows.GetWindowRect(Window, @winRect);
1350
Windows.GetWindowRect(Parent, @parRect);
1351
Left := winRect.Left - parRect.Left;
1352
Top := winRect.Top - parRect.Top;
1355
function GetWindowInfo(AWindow: HWND): TWindowInfo;
1357
Result := TWindowInfo(FindFormWithNativeHandle(AWindow));
1358
if Result = nil then Result := DefaultWindowInfo;
1362
Updates the window style of the window indicated by Handle.
1363
The new style is the Style parameter.
1364
Only the bits set in the StyleMask are changed,
1365
the other bits remain untouched.
1366
If the bits in the StyleMask are not used in the Style,
1369
procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
1374
CurrentStyle := Windows.GetWindowLong(Handle, GWL_STYLE);
1375
NewStyle := (Style and StyleMask) or (CurrentStyle and (not StyleMask));
1376
Windows.SetWindowLong(Handle, GWL_STYLE, NewStyle);
1379
function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
1381
Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
1382
case Application.ApplicationType of
1383
{ Under Desktop or Handheld mode we get an application which
1384
looks similar to a desktop one, with sizable windows }
1388
bsSizeable, bsSizeToolWin:
1389
Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
1390
bsSingle, bsToolWindow:
1391
Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
1393
Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
1395
Result := Result or WS_POPUP;
1398
{ Under PDA or Smartphone modes most windows are enlarged to fit the screen
1399
Dialogs and borderless windows are exceptions }
1400
atPDA, atKeyPadDevice, atDefault:
1404
Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
1406
Result := Result or WS_POPUP;
1408
Result := 0; // Never add WS_VISIBLE here, bug http://bugs.freepascal.org/view.php?id=12193
1414
function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
1418
case Application.ApplicationType of
1424
Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
1425
bsToolWindow, bsSizeToolWin:
1426
Result := WS_EX_TOOLWINDOW;
1430
atPDA, atKeyPadDevice, atDefault:
1433
// Adds an "OK" close button to the title bar instead of the standard
1434
// "X" minimize button, unless the developer overrides that decision
1435
case CDWidgetSet.WinCETitlePolicy of
1437
tpAlwaysUseOKButton: Result := WS_EX_CAPTIONOKBTN;
1440
tpControlWithBorderIcons:
1442
if not (biMinimize in AForm.BorderIcons) then Result := WS_EX_CAPTIONOKBTN;
1445
if Style = bsDialog then Result := WS_EX_CAPTIONOKBTN;
1453
function GetFileVersion(FileName: string): dword;
1457
fixedInfo: ^VS_FIXEDFILEINFO;
1458
WideBuffer: widestring;
1460
Result := $FFFFFFFF;
1461
WideBuffer := UTF8Decode(FileName);
1462
lenBuf := GetFileVersionInfoSizeW(PWideChar(WideBuffer), lenBuf);
1465
GetMem(buf, lenBuf);
1466
if GetFileVersionInfoW(PWideChar(WideBuffer), 0, lenBuf, buf) then
1468
VerQueryValue(buf, '\', pointer(fixedInfo), lenBuf);
1469
Result := fixedInfo^.dwFileVersionMS;
1475
function EnumStayOnTopRemove(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
1477
StayOnTopWindowsInfo: PStayOnTopWindowsInfo absolute Param;
1478
lWindowInfo: TWindowInfo;
1479
lWinControl: TWinControl;
1482
if ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0) then
1484
// Don't remove system-wide stay on top, unless desired
1485
if not StayOnTopWindowsInfo^.SystemTopAlso then
1487
lWindowInfo := TWindowInfo(FindFormWithNativeHandle(Handle));
1488
if Assigned(lWindowInfo) then
1490
lWinControl := lWindowInfo.LCLForm;
1491
if (lWinControl is TCustomForm) and
1492
(TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then
1497
StayOnTopWindowsInfo^.StayOnTopList.Add(Pointer(Handle));
1501
procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False);
1503
StayOnTopWindowsInfo: PStayOnTopWindowsInfo;
1504
WindowInfo: TWindowInfo;
1507
{ //WriteLn('RemoveStayOnTopFlags ', InRemoveStayOnTopFlags);
1508
if InRemoveStayOnTopFlags = 0 then
1510
New(StayOnTopWindowsInfo);
1511
StayOnTopWindowsInfo^.AppHandle := AppHandle;
1512
StayOnTopWindowsInfo^.SystemTopAlso := ASystemTopAlso;
1513
StayOnTopWindowsInfo^.StayOnTopList := TList.Create;
1514
WindowInfo := GetWindowInfo(AppHandle);
1515
WindowInfo^.StayOnTopList := StayOnTopWindowsInfo^.StayOnTopList;
1516
EnumThreadWindows(GetWindowThreadProcessId(AppHandle, nil),
1517
@EnumStayOnTopRemove, LPARAM(StayOnTopWindowsInfo));
1518
for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
1519
SetWindowPos(HWND(WindowInfo^.StayOnTopList[I]), HWND_NOTOPMOST, 0, 0, 0, 0,
1520
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1521
Dispose(StayOnTopWindowsInfo);
1523
inc(InRemoveStayOnTopFlags);}
1526
procedure RestoreStayOnTopFlags(AppHandle: HWND);
1528
WindowInfo: TWindowInfo;
1531
{ //WriteLn('RestoreStayOnTopFlags ', InRemoveStayOnTopFlags);
1532
if InRemoveStayOnTopFlags = 1 then
1534
WindowInfo := GetWindowInfo(AppHandle);
1535
if WindowInfo^.StayOnTopList <> nil then
1537
for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do
1538
SetWindowPos(HWND(WindowInfo^.StayOnTopList.Items[I]),
1539
HWND_TOPMOST, 0, 0, 0, 0,
1540
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME);
1541
FreeAndNil(WindowInfo^.StayOnTopList);
1544
if InRemoveStayOnTopFlags > 0 then
1545
dec(InRemoveStayOnTopFlags);}
1548
function WndClassName(Wnd: HWND): String; inline;
1550
winClassName: array[0..19] of widechar;
1552
GetClassName(Wnd, @winClassName, 20);
1553
Result := winClassName;
1556
function IsAlienWindow(Wnd: HWND): Boolean;
1559
// list window class names is taken here:
1560
// http://www.pocketpcdn.com/print/articles/?&atb.set(c_id)=51&atb.set(a_id)=7165&atb.perform(details)=
1561
AlienWindowClasses: array[0..7] of String =
1563
'menu_worker', // can be also found by SHFindMenuBar
1564
'MS_SOFTKEY_CE_1.0', // google about that one. as I understand it related to bottom menu too
1577
WndName := WndClassName(Wnd);
1579
for i := Low(AlienWindowClasses) to High(AlienWindowClasses) do
1580
if WndName = AlienWindowClasses[i] then
1584
{procedure LogWindow(Window: HWND);
1586
DbgAppendToFile(ExtractFilePath(ParamStr(0)) + '1.log',
1587
'Window = ' + IntToStr(Window) + ' ClassName = ' + WndClassName(Window) + ' Thread id = ' + IntToStr(GetWindowThreadProcessId(Window, nil)));
1590
function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
1592
textSize: Windows.SIZE;
1595
oldFontHandle: HFONT;
1597
winHandle := AWinControl.Handle;
1598
canvasHandle := GetDC(winHandle);
1599
oldFontHandle := SelectObject(canvasHandle, Windows.SendMessage(winHandle, WM_GetFont, 0, 0));
1600
DeleteAmpersands(Text);
1602
Result := LCLIntf.GetTextExtentPoint32(canvasHandle, PChar(Text), Length(Text), textSize);
1606
Width := textSize.cx;
1607
Height := textSize.cy;
1609
SelectObject(canvasHandle, oldFontHandle);
1610
ReleaseDC(winHandle, canvasHandle);
1613
function GetControlText(AHandle: HWND): string;
1616
tmpWideStr: WideString;
1618
TextLen := GetWindowTextLength(AHandle);
1619
SetLength(tmpWideStr, TextLen+1);
1620
GetWindowTextW(AHandle, PWideChar(tmpWideStr), TextLen + 1);
1621
Result := UTF8Encode(tmpWideStr);
1624
procedure WideStrCopy(Dest, Src: PWideChar);
1629
while Src[counter] <> #0 do
1631
Dest[counter] := Src[counter];
1634
Dest[counter] := #0;
1637
{ Exactly equal to StrLCopy but for PWideChars
1638
Copyes a widestring up to a maximal length, in WideChars }
1639
function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
1645
while (Source[counter] <> #0) and (counter < MaxLen) do
1647
Dest[counter] := Source[counter];
1651
{ terminate the string }
1652
Dest[counter] := #0;
1656
function WideStrCmp(W1, W2: PWideChar): Integer;
1661
While W1[counter] = W2[counter] do
1663
if (W2[counter] = #0) or (W1[counter] = #0) then
1667
Result := ord(W1[counter]) - ord(W2[counter]);
1670
function GetWinCEPlatform: TApplicationType;
1673
Result := atDesktop;
1677
buf: array[0..50] of WideChar;
1679
Result := atDefault;
1681
if Windows.SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then
1683
if WideStrCmp(@buf, 'PocketPC') = 0 then
1685
else if WideStrCmp(@buf, 'SmartPhone') = 0 then
1686
Result := atKeyPadDevice
1688
// Other devices can set anything for the platform name,
1689
// see http://bugs.freepascal.org/view.php?id=16615
1690
// Here we just suppose that they are atDesktop
1691
Result := atDesktop;
1693
else if GetLastError = ERROR_ACCESS_DENIED then
1694
Result := atKeyPadDevice
1700
function IsHiResMode: Boolean;
1705
Result := Screen.Width > 240;
1710
{-------------------------------------------------------------------------------
1711
procedure AddToChangedMenus(Window: HWnd);
1713
Adds Window to the list of windows which need to redraw the main menu.
1714
-------------------------------------------------------------------------------}
1715
procedure AddToChangedMenus(Window: HWnd);
1717
if ChangedMenus.IndexOf(Pointer(Window)) = -1 then // Window handle is not yet in the list
1718
ChangedMenus.Add(Pointer(Window));
1721
{------------------------------------------------------------------------------
1726
Redraws all changed menus
1727
------------------------------------------------------------------------------}
1728
procedure RedrawMenus;
1732
for I := 0 to ChangedMenus.Count - 1 do
1733
DrawMenuBar(HWND(ChangedMenus[I]));
1737
procedure UpdateWindowsVersion;
1740
versionInfo: OSVERSIONINFO;
1742
WindowsVersion := wince_other;
1744
System.FillChar(versionInfo, sizeof(OSVERSIONINFO), #0);
1745
versionInfo.dwOSVersionInfoSize := sizeof(OSVERSIONINFO);
1747
if GetVersionEx(@versionInfo) then
1749
case versionInfo.dwMajorVersion of
1750
1: WindowsVersion := wince_1;
1751
2: WindowsVersion := Wince_2;
1752
3: WindowsVersion := Wince_3;
1753
4: WindowsVersion := Wince_4;
1756
if versionInfo.dwMinorVersion = 2 then WindowsVersion := Wince_6
1757
else WindowsVersion := Wince_5;
1759
6: WindowsVersion := Wince_6;
1765
case Win32MajorVersion of
1768
if Win32Platform = VER_PLATFORM_WIN32_NT
1769
then WindowsVersion := wvNT4
1771
case Win32MinorVersion of
1772
10: WindowsVersion := wv98;
1773
90: WindowsVersion := wvME;
1775
WindowsVersion :=wv95;
1779
case Win32MinorVersion of
1780
0: WindowsVersion := wv2000;
1781
1: WindowsVersion := wvXP;
1783
// XP64 has also a 5.2 version
1784
// we could detect that based on arch and versioninfo.Producttype
1785
WindowsVersion := wvServer2003;
1789
case Win32MinorVersion of
1790
0: WindowsVersion := wvVista;
1791
1: WindowsVersion := wv7;
1793
WindowsVersion := wvLater;
1797
WindowsVersion := wvLater;
1803
DefaultWindowInfo := TWindowInfo.Create;
1804
WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
1805
ChangedMenus := TList.Create;
1806
UpdateWindowsVersion();
1809
Windows.GlobalDeleteAtom(WindowInfoAtom);
1810
WindowInfoAtom := 0;
added
removed
lcl/interfaces/customdrawn/customdrawn_winproc.pas
