1unit winceproc;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8  // Libs
9  Windows,
10  {$ifdef win32}
11  win32compat,
12  {$else}
13    oleauto, aygshell,
14  {$endif}
15  // compatibility
16  // RTL, LCL
17  Classes, LMessages, LCLType, LCLProc, LazUTF8, Controls, Forms, Menus,
18  WinCEExtra, GraphType, LCLMessageGlue;
19
20type
21  TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown);
22
23  PWindowInfo = ^TWindowInfo;
24  TWindowInfo = record
25    Overlay: HWND;            // overlay, transparent window on top, used by designer
26    PopupMenu: TPopupMenu;
27    DefWndProc: WNDPROC;
28    ParentPanel: HWND;        // if non-zero, is the tabsheet window, for the pagecontrol hack
29    WinControl: TWinControl;
30    PWinControl: TWinControl; // control to paint for
31    AWinControl: TWinControl; // control associated with (for buddy controls)
32    List: TStrings;
33    needParentPaint: boolean; // has a tabpage as parent, and is winxp themed
34//    isTabPage: boolean;       // is window of tabpage
35    isComboEdit: boolean;     // is buddy of combobox, the edit control
36    isChildEdit: boolean;     // is buddy edit of a control
37    isGroupBox: boolean;      // is groupbox, and does not have themed tabpage as parent
38    MaxLength: dword;
39    DrawItemIndex: integer;   // in case of listbox, when handling WM_DRAWITEM
40    DrawItemSelected: boolean;// whether this item is selected LB_GETSEL not uptodate yet
41    MouseX, MouseY: word; // noticing spurious WM_MOUSEMOVE messages
42    case integer of
43      0: (spinValue: Double);
44      1: (
45        TrackValid: Boolean; // Set when we have a valid trackpos
46        TrackPos: Integer    // keeps the thumb position while tracking
47      );
48  end;
49
50  TWinCEVersion = (wince_1, wince_2, wince_3, wince_4,
51   wince_5, wince_6, wince_6_1, wince_6_5, wince_7,
52   wince_other);
53
54function WM_To_String(WM_Message: Integer): string;
55function WindowPosFlagsToString(Flags: UINT): string;
56procedure AssertEx(const Message: String; const PassErr: Boolean;
57  const Severity: Byte);
58procedure AssertEx(const PassErr: Boolean; const Message: String);
59procedure AssertEx(const Message: String);
60function ObjectToHWND(Const AObject: TObject): HWND;
61
62function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
63function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
64procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
65procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
66
67function GetBitmapBytes(ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; var AData: Pointer; var ADataSize: PtrUInt): Boolean;
68function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
69function IsAlphaDC(ADC: HDC): Boolean;
70
71function GetLastErrorText(AErrorCode: Cardinal): WideString;
72
73function LCLControlSizeNeedsUpdate(Sender: TWinControl;
74  SendSizeMsgOnDiff: boolean): boolean;
75
76function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
77function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
78procedure LCLBoundsToWin32Bounds(Sender: TObject;
79  var Left, Top, Width, Height: Integer);
80procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
81procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
82
83procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
84function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
85function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
86
87function GetFileVersion(FileName: string): dword;
88function AllocWindowInfo(Window: HWND): PWindowInfo;
89function DisposeWindowInfo(Window: HWND): boolean;
90function GetWindowInfo(Window: HWND): PWindowInfo;
91procedure AddToChangedMenus(Window: HWnd);
92procedure RedrawMenus;
93function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
94function GetControlText(AHandle: HWND): string;
95
96{ String functions that may be moved to the RTL in the future }
97procedure WideStrCopy(Dest, Src: PWideChar);
98function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
99function WideStrCmp(W1, W2: PWideChar): Integer;
100
101{ Automatic detection of platform }
102function GetWinCEPlatform: TApplicationType;
103function GetWinCEVersion: TWinCEVersion;
104function IsHiResMode: Boolean;
105
106var
107  DefaultWindowInfo: TWindowInfo;
108  WindowInfoAtom: ATOM;
109  OverwriteCheck: Integer = 0;
110  ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn
111
112
113implementation
114
115uses
116  SysUtils, LCLStrConsts, Dialogs, StdCtrls, ExtCtrls, ComCtrls,
117  WinCEInt,
118  LCLIntf; //remove this unit when GetWindowSize is moved to TWSWinControl
119
120{------------------------------------------------------------------------------
121  Function: WM_To_String
122  Params: WM_Message - a WinDows message
123  Returns: A WinDows-message name
124
125  Converts a winDows message identIfier to a string
126 ------------------------------------------------------------------------------}
127function WM_To_String(WM_Message: Integer): string;
128Begin
129 Case WM_Message of
130  $0000: Result := 'WM_NULL';
131  $0001: Result := 'WM_CREATE';
132  $0002: Result := 'WM_DESTROY';
133  $0003: Result := 'WM_MOVE';
134  $0005: Result := 'WM_SIZE';
135  $0006: Result := 'WM_ACTIVATE';
136  $0007: Result := 'WM_SETFOCUS';
137  $0008: Result := 'WM_KILLFOCUS';
138  $000A: Result := 'WM_ENABLE';
139  $000B: Result := 'WM_SETREDRAW';
140  $000C: Result := 'WM_SETTEXT';
141  $000D: Result := 'WM_GETTEXT';
142  $000E: Result := 'WM_GETTEXTLENGTH';
143  $000F: Result := 'WM_PAINT';
144  $0010: Result := 'WM_CLOSE';
145  $0011: Result := 'WM_QUERYENDSESSION';
146  $0012: Result := 'WM_QUIT';
147  $0013: Result := 'WM_QUERYOPEN';
148  $0014: Result := 'WM_ERASEBKGND';
149  $0015: Result := 'WM_SYSCOLORCHANGE';
150  $0016: Result := 'WM_EndSESSION';
151  $0017: Result := 'WM_SYSTEMERROR';
152  $0018: Result := 'WM_SHOWWINDOW';
153  $0019: Result := 'WM_CTLCOLOR';
154  $001A: Result := 'WM_WININICHANGE or WM_SETTINGCHANGE';
155  $001B: Result := 'WM_DEVMODECHANGE';
156  $001C: Result := 'WM_ACTIVATEAPP';
157  $001D: Result := 'WM_FONTCHANGE';
158  $001E: Result := 'WM_TIMECHANGE';
159  $001F: Result := 'WM_CANCELMODE';
160  $0020: Result := 'WM_SETCURSOR';
161  $0021: Result := 'WM_MOUSEACTIVATE';
162  $0022: Result := 'WM_CHILDACTIVATE';
163  $0023: Result := 'WM_QUEUESYNC';
164  $0024: Result := 'WM_GETMINMAXINFO';
165  $0026: Result := 'WM_PAINTICON';
166  $0027: Result := 'WM_ICONERASEBKGND';
167  $0028: Result := 'WM_NEXTDLGCTL';
168  $002A: Result := 'WM_SPOOLERSTATUS';
169  $002B: Result := 'WM_DRAWITEM';
170  $002C: Result := 'WM_MEASUREITEM';
171  $002D: Result := 'WM_DELETEITEM';
172  $002E: Result := 'WM_VKEYTOITEM';
173  $002F: Result := 'WM_CHARTOITEM';
174  $0030: Result := 'WM_SETFONT';
175  $0031: Result := 'WM_GETFONT';
176  $0032: Result := 'WM_SETHOTKEY';
177  $0033: Result := 'WM_GETHOTKEY';
178  $0037: Result := 'WM_QUERYDRAGICON';
179  $0039: Result := 'WM_COMPAREITEM';
180  $003D: Result := 'WM_GETOBJECT';
181  $0041: Result := 'WM_COMPACTING';
182  $0044: Result := 'WM_COMMNOTIFY { obsolete in Win32}';
183  $0046: Result := 'WM_WINDOWPOSCHANGING';
184  $0047: Result := 'WM_WINDOWPOSCHANGED';
185  $0048: Result := 'WM_POWER';
186  $004A: Result := 'WM_COPYDATA';
187  $004B: Result := 'WM_CANCELJOURNAL';
188  $004E: Result := 'WM_NOTIFY';
189  $0050: Result := 'WM_INPUTLANGCHANGEREQUEST';
190  $0051: Result := 'WM_INPUTLANGCHANGE';
191  $0052: Result := 'WM_TCARD';
192  $0053: Result := 'WM_HELP';
193  $0054: Result := 'WM_USERCHANGED';
194  $0055: Result := 'WM_NOTIFYFORMAT';
195  $007B: Result := 'WM_CONTEXTMENU';
196  $007C: Result := 'WM_STYLECHANGING';
197  $007D: Result := 'WM_STYLECHANGED';
198  $007E: Result := 'WM_DISPLAYCHANGE';
199  $007F: Result := 'WM_GETICON';
200  $0080: Result := 'WM_SETICON';
201  $0081: Result := 'WM_NCCREATE';
202  $0082: Result := 'WM_NCDESTROY';
203  $0083: Result := 'WM_NCCALCSIZE';
204  $0084: Result := 'WM_NCHITTEST';
205  $0085: Result := 'WM_NCPAINT';
206  $0086: Result := 'WM_NCACTIVATE';
207  $0087: Result := 'WM_GETDLGCODE';
208  $00A0: Result := 'WM_NCMOUSEMOVE';
209  $00A1: Result := 'WM_NCLBUTTONDOWN';
210  $00A2: Result := 'WM_NCLBUTTONUP';
211  $00A3: Result := 'WM_NCLBUTTONDBLCLK';
212  $00A4: Result := 'WM_NCRBUTTONDOWN';
213  $00A5: Result := 'WM_NCRBUTTONUP';
214  $00A6: Result := 'WM_NCRBUTTONDBLCLK';
215  $00A7: Result := 'WM_NCMBUTTONDOWN';
216  $00A8: Result := 'WM_NCMBUTTONUP';
217  $00A9: Result := 'WM_NCMBUTTONDBLCLK';
218  $0100: Result := 'WM_KEYFIRST or WM_KEYDOWN';
219  $0101: Result := 'WM_KEYUP';
220  $0102: Result := 'WM_CHAR';
221  $0103: Result := 'WM_DEADCHAR';
222  $0104: Result := 'WM_SYSKEYDOWN';
223  $0105: Result := 'WM_SYSKEYUP';
224  $0106: Result := 'WM_SYSCHAR';
225  $0107: Result := 'WM_SYSDEADCHAR';
226  $0108: Result := 'WM_KEYLAST';
227  $010D: Result := 'WM_IME_STARTCOMPOSITION';
228  $010E: Result := 'WM_IME_ENDCOMPOSITION';
229  $010F: Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST';
230  $0110: Result := 'WM_INITDIALOG';
231  $0111: Result := 'WM_COMMAND';
232  $0112: Result := 'WM_SYSCOMMAND';
233  $0113: Result := 'WM_TIMER';
234  $0114: Result := 'WM_HSCROLL';
235  $0115: Result := 'WM_VSCROLL';
236  $0116: Result := 'WM_INITMENU';
237  $0117: Result := 'WM_INITMENUPOPUP';
238  $011F: Result := 'WM_MENUSELECT';
239  $0120: Result := 'WM_MENUCHAR';
240  $0121: Result := 'WM_ENTERIDLE';
241  $0122: Result := 'WM_MENURBUTTONUP';
242  $0123: Result := 'WM_MENUDRAG';
243  $0124: Result := 'WM_MENUGETOBJECT';
244  $0125: Result := 'WM_UNINITMENUPOPUP';
245  $0126: Result := 'WM_MENUCOMMAND';
246  $0132: Result := 'WM_CTLCOLORMSGBOX';
247  $0133: Result := 'WM_CTLCOLOREDIT';
248  $0134: Result := 'WM_CTLCOLORLISTBOX';
249  $0135: Result := 'WM_CTLCOLORBTN';
250  $0136: Result := 'WM_CTLCOLORDLG';
251  $0137: Result := 'WM_CTLCOLORSCROLLBAR';
252  $0138: Result := 'WM_CTLCOLORSTATIC';
253  $0200: Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE';
254  $0201: Result := 'WM_LBUTTONDOWN';
255  $0202: Result := 'WM_LBUTTONUP';
256  $0203: Result := 'WM_LBUTTONDBLCLK';
257  $0204: Result := 'WM_RBUTTONDOWN';
258  $0205: Result := 'WM_RBUTTONUP';
259  $0206: Result := 'WM_RBUTTONDBLCLK';
260  $0207: Result := 'WM_MBUTTONDOWN';
261  $0208: Result := 'WM_MBUTTONUP';
262  $0209: Result := 'WM_MBUTTONDBLCLK';
263  $020A: Result := 'WM_MOUSEWHEEL or WM_MOUSELAST';
264  $0210: Result := 'WM_PARENTNOTIFY';
265  $0211: Result := 'WM_ENTERMENULOOP';
266  $0212: Result := 'WM_EXITMENULOOP';
267  $0213: Result := 'WM_NEXTMENU';
268  $0214: Result := 'WM_SIZING';
269  $0215: Result := 'WM_CAPTURECHANGED';
270  $0216: Result := 'WM_MOVING';
271  $0218: Result := 'WM_POWERBROADCAST';
272  $0219: Result := 'WM_DEVICECHANGE';
273  $0220: Result := 'WM_MDICREATE';
274  $0221: Result := 'WM_MDIDESTROY';
275  $0222: Result := 'WM_MDIACTIVATE';
276  $0223: Result := 'WM_MDIRESTORE';
277  $0224: Result := 'WM_MDINEXT';
278  $0225: Result := 'WM_MDIMAXIMIZE';
279  $0226: Result := 'WM_MDITILE';
280  $0227: Result := 'WM_MDICASCADE';
281  $0228: Result := 'WM_MDIICONARRANGE';
282  $0229: Result := 'WM_MDIGETACTIVE';
283  $0230: Result := 'WM_MDISETMENU';
284  $0231: Result := 'WM_ENTERSIZEMOVE';
285  $0232: Result := 'WM_EXITSIZEMOVE';
286  $0233: Result := 'WM_DROPFILES';
287  $0234: Result := 'WM_MDIREFRESHMENU';
288  $0281: Result := 'WM_IME_SETCONTEXT';
289  $0282: Result := 'WM_IME_NOTIFY';
290  $0283: Result := 'WM_IME_CONTROL';
291  $0284: Result := 'WM_IME_COMPOSITIONFULL';
292  $0285: Result := 'WM_IME_SELECT';
293  $0286: Result := 'WM_IME_CHAR';
294  $0288: Result := 'WM_IME_REQUEST';
295  $0290: Result := 'WM_IME_KEYDOWN';
296  $0291: Result := 'WM_IME_KEYUP';
297  $02A1: Result := 'WM_MOUSEHOVER';
298  $02A3: Result := 'WM_MOUSELEAVE';
299  $0300: Result := 'WM_CUT';
300  $0301: Result := 'WM_COPY';
301  $0302: Result := 'WM_PASTE';
302  $0303: Result := 'WM_CLEAR';
303  $0304: Result := 'WM_UNDO';
304  $0305: Result := 'WM_RENDERFORMAT';
305  $0306: Result := 'WM_RENDERALLFORMATS';
306  $0307: Result := 'WM_DESTROYCLIPBOARD';
307  $0308: Result := 'WM_DRAWCLIPBOARD';
308  $0309: Result := 'WM_PAINTCLIPBOARD';
309  $030A: Result := 'WM_VSCROLLCLIPBOARD';
310  $030B: Result := 'WM_SIZECLIPBOARD';
311  $030C: Result := 'WM_ASKCBFORMATNAME';
312  $030D: Result := 'WM_CHANGECBCHAIN';
313  $030E: Result := 'WM_HSCROLLCLIPBOARD';
314  $030F: Result := 'WM_QUERYNEWPALETTE';
315  $0310: Result := 'WM_PALETTEISCHANGING';
316  $0311: Result := 'WM_PALETTECHANGED';
317  $0312: Result := 'WM_HOTKEY';
318  $0317: Result := 'WM_PRINT';
319  $0318: Result := 'WM_PRINTCLIENT';
320  $0358: Result := 'WM_HANDHELDFIRST';
321  $035F: Result := 'WM_HANDHELDLAST';
322  $0380: Result := 'WM_PENWINFIRST';
323  $038F: Result := 'WM_PENWINLAST';
324  $0390: Result := 'WM_COALESCE_FIRST';
325  $039F: Result := 'WM_COALESCE_LAST';
326  $03E0: Result := 'WM_DDE_FIRST or WM_DDE_INITIATE';
327  $03E1: Result := 'WM_DDE_TERMINATE';
328  $03E2: Result := 'WM_DDE_ADVISE';
329  $03E3: Result := 'WM_DDE_UNADVISE';
330  $03E4: Result := 'WM_DDE_ACK';
331  $03E5: Result := 'WM_DDE_DATA';
332  $03E6: Result := 'WM_DDE_REQUEST';
333  $03E7: Result := 'WM_DDE_POKE';
334  $03E8: Result := 'WM_DDE_EXECUTE or WM_DDE_LAST';
335  $0400: Result := 'WM_USER';
336  $8000: Result := 'WM_APP';
337  Else
338    Result := 'Unknown(' + IntToStr(WM_Message) + ')';
339  End; {Case}
340End;
341
342function WindowPosFlagsToString(Flags: UINT): string;
343var
344  FlagsStr: string;
345begin
346  FlagsStr := '';
347  if (Flags and SWP_DRAWFRAME) <> 0 then
348    FlagsStr := FlagsStr + '|SWP_DRAWFRAME';
349  if (Flags and SWP_HIDEWINDOW) <> 0 then
350    FlagsStr := FlagsStr + '|SWP_HIDEWINDOW';
351  if (Flags and SWP_NOACTIVATE) <> 0 then
352    FlagsStr := FlagsStr + '|SWP_NOACTIVATE';
353  if (Flags and SWP_NOCOPYBITS) <> 0 then
354    FlagsStr := FlagsStr + '|SWP_NOCOPYBITS';
355  if (Flags and SWP_NOMOVE) <> 0 then
356    FlagsStr := FlagsStr + '|SWP_NOMOVE';
357  if (Flags and SWP_NOOWNERZORDER) <> 0 then
358    FlagsStr := FlagsStr + '|SWP_NOOWNERZORDER';
359  if (Flags and SWP_NOREDRAW) <> 0 then
360    FlagsStr := FlagsStr + '|SWP_NOREDRAW';
361  if (Flags and SWP_NOSENDCHANGING) <> 0 then
362    FlagsStr := FlagsStr + '|SWP_NOSENDCHANGING';
363  if (Flags and SWP_NOSIZE) <> 0 then
364    FlagsStr := FlagsStr + '|SWP_NOSIZE';
365  if (Flags and SWP_NOZORDER) <> 0 then
366    FlagsStr := FlagsStr + '|SWP_NOZORDER';
367  if (Flags and SWP_SHOWWINDOW) <> 0 then
368    FlagsStr := FlagsStr + '|SWP_SHOWWINDOW';
369  if Length(FlagsStr) > 0 then
370    FlagsStr := Copy(FlagsStr, 2, Length(FlagsStr)-1);
371  Result := FlagsStr;
372end;
373
374{------------------------------------------------------------------------------
375  Function: AssertEx
376  Params: Message  - Message sent
377          PassErr  - Pass error to a catching procedure (default: False)
378          Severity - How severe is the error on a scale from 0 to 3
379                     (default: 0)
380  Returns: Nothing
381
382  An expanded, better version of Assert
383 ------------------------------------------------------------------------------}
384procedure AssertEx(Const Message: String; Const PassErr: Boolean; Const Severity: Byte);
385Begin
386  Case Severity Of
387    0:
388    Begin
389      Assert(PassErr, Message);
390    End;
391    1:
392    Begin
393      Assert(PassErr, Format('Trace:%S', [Message]));
394    End;
395    2:
396    Begin
397      Case IsConsole Of
398        True:
399        Begin
400          DebugLn(rsWin32Warning, Message);
401        End;
402        False:
403        Begin
404          MessageBox(0, PChar(Message), PChar(rsWin32Warning), MB_OK);
405        End;
406      End;
407    End;
408    3:
409    Begin
410      Case IsConsole Of
411        True:
412        Begin
413          DebugLn(rsWin32Error, Message);
414        End;
415        False:
416        Begin
417          MessageBox(0, PChar(Message), Nil, MB_OK);
418        End;
419      End;
420    End;
421  End;
422End;
423
424procedure AssertEx(Const PassErr: Boolean; Const Message: String);
425Begin
426  AssertEx(Message, PassErr, 0);
427End;
428
429procedure AssertEx(Const Message: String);
430Begin
431  AssertEx(Message, False, 0);
432End;
433
434{------------------------------------------------------------------------------
435  Procedure: GetWin32KeyInfo
436  Params:  Event      - Requested info
437           KeyCode    - the ASCII key code of the eventkey
438           VirtualKey - the virtual key code of the eventkey
439           SysKey     - True If the key is a syskey
440           ExtEnded   - True If the key is an extended key
441           Toggle     - True If the key is a toggle key and its value is on
442  Returns: Nothing
443
444  GetWin32KeyInfo returns information about the given key event
445 ------------------------------------------------------------------------------}
446{
447procedure GetWin32KeyInfo(const Event: Integer; var KeyCode, VirtualKey: Integer; var SysKey, Extended, Toggle: Boolean);
448Const
449  MVK_UNIFY_SIDES = 1;
450Begin
451  //DebugLn('TRACE:Using function GetWin32KeyInfo which isn''t implemented yet');
452  KeyCode := Word(Event);
453  VirtualKey := MapVirtualKey(KeyCode, MVK_UNIFY_SIDES);
454  SysKey := (VirtualKey = VK_SHIFT) Or (VirtualKey = VK_CONTROL) Or (VirtualKey = VK_MENU);
455  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);
456  Toggle := Lo(GetKeyState(VirtualKey)) = 1;
457End;
458}
459
460{------------------------------------------------------------------------------
461  Function: ObjectToHWND
462  Params: AObject - An LCL Object
463  Returns: The Window handle of the given object
464
465  Returns the Window handle of the given object, 0 if no object available
466 ------------------------------------------------------------------------------}
467function ObjectToHWND(Const AObject: TObject): HWND;
468Var
469  Handle: HWND;
470Begin
471  Handle:=0;
472  If not assigned(AObject) Then
473  Begin
474    Assert (False, 'TRACE:[ObjectToHWND] Object not assigned');
475  End
476  Else If (AObject Is TWinControl) Then
477  Begin
478    If TWinControl(AObject).HandleAllocated Then
479      Handle := TWinControl(AObject).Handle
480  End
481  Else If (AObject Is TMenuItem) Then
482  Begin
483    If TMenuItem(AObject).HandleAllocated Then
484      Handle := TMenuItem(AObject).Handle
485  End
486  Else If (AObject Is TMenu) Then
487  Begin
488    If TMenu(AObject).HandleAllocated Then
489      Handle := TMenu(AObject).Items.Handle
490  End
491//  Else If (AObject Is TCommonDialog) Then
492//  Begin
493//    {If TCommonDialog(AObject).HandleAllocated Then }
494//    Handle := TCommonDialog(AObject).Handle
495//  End
496  Else
497  Begin
498    //DebugLn(Format('Trace:[ObjectToHWND] Message received With unhandled class-type <%s>', [AObject.ClassName]));
499  End;
500  Result := Handle;
501  If Handle = 0 Then
502    Assert (False, 'Trace:[ObjectToHWND]****** Warning: handle = 0 *******');
503end;
504
505function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt;
506begin
507  Result := ((nWidth * nBitsPerPixel + 31) and (not 31) ) div 8;
508end;
509
510procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
511begin
512  case ADesc.BitsPerPixel of
513    1,4,8:
514      begin
515        // palette mode, no offsets
516        ADesc.Format := ricfGray;
517        ADesc.RedPrec := ADesc.BitsPerPixel;
518        ADesc.GreenPrec := 0;
519        ADesc.BluePrec := 0;
520        ADesc.RedShift := 0;
521        ADesc.GreenShift := 0;
522        ADesc.BlueShift := 0;
523      end;
524    16:
525      begin
526        // 5-6-5 mode
527        //roozbeh all changed from 5-5-5 to 5-6-5
528        ADesc.RedPrec := 5;
529        ADesc.GreenPrec := 6;
530        ADesc.BluePrec := 5;
531        ADesc.RedShift := 11;
532        ADesc.GreenShift := 5;
533        ADesc.BlueShift := 0;
534        ADesc.Depth := 16;
535      end;
536    24:
537      begin
538        // 8-8-8 mode
539        ADesc.RedPrec := 8;
540        ADesc.GreenPrec := 8;
541        ADesc.BluePrec := 8;
542        ADesc.RedShift := 16;
543        ADesc.GreenShift := 8;
544        ADesc.BlueShift := 0;
545      end;
546  else    //  32:
547    // 8-8-8-8 mode, high byte can be native alpha or custom 1bit maskalpha
548    ADesc.AlphaPrec := 8;
549    ADesc.RedPrec := 8;
550    ADesc.GreenPrec := 8;
551    ADesc.BluePrec := 8;
552    ADesc.AlphaShift := 24;
553    ADesc.RedShift := 16;
554    ADesc.GreenShift := 8;
555    ADesc.BlueShift := 0;
556    ADesc.Depth := 32;
557  end;
558end;
559
560
561procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
562begin
563  ADesc.Init;
564  ADesc.Format := ricfRGBA;
565  ADesc.Depth := ABitmapInfo.bmBitsPixel;             // used bits per pixel
566  ADesc.Width := ABitmapInfo.bmWidth;
567  ADesc.Height := ABitmapInfo.bmHeight;
568  ADesc.BitOrder := riboReversedBits;
569  ADesc.ByteOrder := riboLSBFirst;
570  ADesc.LineOrder := riloTopToBottom;
571  ADesc.BitsPerPixel := ABitmapInfo.bmBitsPixel;      // bits per pixel. can be greater than Depth.
572  ADesc.LineEnd := rileDWordBoundary;
573
574  if ABitmapInfo.bmBitsPixel <= 8
575  then begin
576    // each pixel is an index in the palette
577    // TODO, ColorCount
578    ADesc.PaletteColorCount := 0;
579  end
580  else ADesc.PaletteColorCount := 0;
581
582  FillRawImageDescriptionColors(ADesc);
583
584  ADesc.MaskBitsPerPixel := 1;
585  ADesc.MaskShift := 0;
586  ADesc.MaskLineEnd := rileWordBoundary; // CreateBitmap requires word boundary
587  ADesc.MaskBitOrder := riboReversedBits;
588end;
589
590function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP;
591  function GetMask(APrec, AShift: Byte): Cardinal;
592  begin
593    Result := ($FFFFFFFF shr (32-APrec)) shl AShift;
594  end;
595
596var
597  Info: record
598    Header: Windows.TBitmapInfoHeader;
599    Colors: array[0..3] of Cardinal; // reserve extra color for colormasks
600  end;
601begin
602  FillChar(Info, sizeof(Info), 0);
603  Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader);
604  Info.Header.biWidth := ADesc.Width;
605  Info.Header.biHeight := -ADesc.Height;
606  Info.Header.biPlanes := 1;
607  Info.Header.biBitCount := ADesc.BitsPerPixel;
608  // TODO: palette support
609  Info.Header.biClrUsed := 0;
610  Info.Header.biClrImportant := 0;
611  Info.Header.biSizeImage := BytesPerLine(Info.Header.biWidth, Info.Header.biBitCount) * ADesc.Height;
612  // CE only supports bitfields
613  if ADesc.BitsPerPixel > 8
614  then Info.Header.biCompression := BI_BITFIELDS
615  else Info.Header.biCompression := BI_RGB;
616
617  if ADesc.BitsPerPixel = 1
618  then begin
619    // mono bitmap: first color is black, second is white
620    Info.Colors[1] := $FFFFFFFF;
621  end
622  else begin
623    // when 24bpp, CE only supports B8G8R8 encoding
624    // TODO: check the description
625    Info.Colors[0] := GetMask(ADesc.RedPrec, ADesc.RedShift);
626    Info.Colors[1] := GetMask(ADesc.GreenPrec, ADesc.GreenShift);
627    Info.Colors[2] := GetMask(ADesc.BluePrec, ADesc.BlueShift);
628  end;
629
630  // Use createDIBSection, since only devicedepth bitmaps can be selected into a DC
631  // when they are created with createDIBitmap
632  Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, ABitsPtr, 0, 0);
633
634  //DbgDumpBitmap(Result, 'CreateDIBSectionFromDescription - Image');
635end;
636
637function CreateDIBSectionFromDDB(ASource: HBitmap; out ABitsPtr: Pointer): HBitmap;
638var
639  ADC, SrcDC, DstDC: HDC;
640  ADesc: TRawImageDescription;
641  SrcOldBm, DstOldBm: HBitmap;
642begin
643  Result := 0;
644
645  // get source bitmap description
646  if not RawImage_DescriptionFromBitmap(ASource, ADesc) then
647    Exit;
648
649  // create apropriate dib section
650  ADC := GetDC(0);
651  Result := CreateDIBSectionFromDescription(ADC, ADesc, ABitsPtr);
652  ReleaseDC(0, ADC);
653
654  if Result = 0 then
655    Exit;
656
657  // copy source bitmap into destination
658  SrcDC := CreateCompatibleDC(0);
659  SrcOldBm := SelectObject(SrcDC, ASource);
660  DstDC := CreateCompatibleDC(0);
661  DstOldBm := SelectObject(DstDC, Result);
662  Windows.BitBlt(DstDC, 0, 0, ADesc.Width, ADesc.Height, SrcDC, 0, 0, SRCCOPY);
663  SelectObject(SrcDC, SrcOldBm);
664  SelectObject(DstDC, DstOldBm);
665  DeleteDC(SrcDC);
666  DeleteDC(DstDC);
667end;
668
669function GetBitmapBytes(ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; var AData: Pointer; var ADataSize: PtrUInt): Boolean;
670var
671  Section: Windows.TDIBSection;
672  DIBCopy: HBitmap;
673  DIBData: Pointer;
674begin
675  Result := False;
676  // first try if the bitmap is created as section
677  if (Windows.GetObject(ABitmap, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
678  then begin
679    with Section.dsBm do
680      Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
681    Exit;
682  end;
683
684  // bitmap is not a section, retrieve only bitmap
685  if Windows.GetObject(ABitmap, SizeOf(Section.dsBm), @Section) = 0
686  then Exit;
687
688  DIBCopy := CreateDIBSectionFromDDB(ABitmap, DIBData);
689  if DIBCopy = 0 then
690    Exit;
691  if (Windows.GetObject(DIBCopy, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil)
692  then begin
693    with Section.dsBm do
694      Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize);
695  end;
696
697  DeleteObject(DIBCopy);
698
699  Result := True;
700end;
701
702function IsAlphaBitmap(ABitmap: HBITMAP): Boolean;
703var
704  Info: Windows.BITMAP;
705begin
706  FillChar(Info, SizeOf(Info), 0);
707  Result := (GetObject(ABitmap, SizeOf(Info), @Info) <> 0)
708        and (Info.bmBitsPixel = 32);
709end;
710
711function IsAlphaDC(ADC: HDC): Boolean;
712begin
713  Result := (GetObjectType(ADC) = OBJ_MEMDC)
714        and IsAlphaBitmap(GetCurrentObject(ADC, OBJ_BITMAP));
715end;
716
717function GetLastErrorText(AErrorCode: Cardinal): WideString;
718var
719  r: cardinal;
720  tmp: PWideChar;
721begin
722  tmp := nil;
723  r := Windows.FormatMessage(
724    FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
725    nil, AErrorCode, LANG_NEUTRAL, @tmp, 0, nil);
726
727  if r = 0 then Exit('');
728
729  Result := tmp;
730  SetLength(Result, Length(Result)-2);
731
732  if tmp <> nil
733  then LocalFree(HLOCAL(tmp));
734end;
735
736(***********************************************************************
737  Widget member Functions
738************************************************************************)
739
740{-------------------------------------------------------------------------------
741  function LCLBoundsNeedsUpdate(Sender: TWinControl;
742    SendSizeMsgOnDiff: boolean): boolean;
743
744  Returns true if LCL bounds and win32 bounds differ for the control.
745-------------------------------------------------------------------------------}
746function LCLControlSizeNeedsUpdate(Sender: TWinControl;
747  SendSizeMsgOnDiff: boolean): boolean;
748var
749  Window:HWND;
750  LMessage: TLMSize;
751  IntfWidth, IntfHeight: integer;
752begin
753  Result:=false;
754  Window:= Sender.Handle;
755  LCLIntf.GetWindowSize(Window, IntfWidth, IntfHeight);
756  if (Sender.Width = IntfWidth)
757  and (Sender.Height = IntfHeight)
758  and (not Sender.ClientRectNeedsInterfaceUpdate) then
759    exit;
760  Result:=true;
761  if SendSizeMsgOnDiff then
762  begin
763    //writeln('LCLBoundsNeedsUpdate B ',TheWinControl.Name,':',TheWinControl.ClassName,' Sending WM_SIZE');
764    Sender.InvalidateClientRectCache(true);
765    // send message directly to LCL, some controls not subclassed -> message
766    // never reaches LCL
767    with LMessage do
768    begin
769      Msg := LM_SIZE;
770      SizeType := SIZE_RESTORED or Size_SourceIsInterface;
771      Width := IntfWidth;
772      Height := IntfHeight;
773    end;
774    DeliverMessage(Sender, LMessage);
775  end;
776end;
777
778{-------------------------------------------------------------------------------
779  function GetLCLClientOriginOffset(Sender: TObject;
780    var LeftOffset, TopOffset: integer): boolean;
781
782  Returns the difference between the client origin of a win32 handle
783  and the definition of the LCL counterpart.
784  For example:
785    TGroupBox's client area is the area inside the groupbox frame.
786    Hence, the LeftOffset is the frame width and the TopOffset is the caption
787    height.
788-------------------------------------------------------------------------------}
789function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
790var
791  TM: TextMetric;
792  DC: HDC;
793  Handle: HWND;
794  TheWinControl: TWinControl absolute Sender;
795  ARect: TRect;
796begin
797  Result:=false;
798  if (Sender = nil) or (not (Sender is TWinControl)) then exit;
799  if not TheWinControl.HandleAllocated then exit;
800  Handle := TheWinControl.Handle;
801  FillChar(ORect, SizeOf(ORect), 0);
802  if TheWinControl is TScrollingWinControl then
803    with TScrollingWinControl(TheWinControl) do
804    begin
805      if HorzScrollBar <> nil then
806      begin
807        // left and right bounds are shifted by scroll position
808        ORect.Left := -HorzScrollBar.Position;
809        ORect.Right := -HorzScrollBar.Position;
810      end;
811      if VertScrollBar <> nil then
812      begin
813        // top and bottom bounds are shifted by scroll position
814        ORect.Top := -VertScrollBar.Position;
815        ORect.Bottom := -VertScrollBar.Position;
816      end;
817    end;
818  if (TheWinControl is TCustomGroupBox) then
819  begin
820    // The client area of a groupbox under winapi is the whole size, including
821    // the frame. The LCL defines the client area without the frame.
822    // -> Adjust the position
823    // add the upper frame with the caption
824    DC := Windows.GetDC(Handle);
825    GetTextMetrics(DC, TM);
826    ORect.Top := TM.TMHeight;
827//    DbgAppendToFile(ExtractFilePath(ParamStr(0)) + '1.log',
828//      'GetLCLClientBoundsOffset Handle: ' + IntToStr(Handle) +
829//      ' Top: ' + IntToStr(TM.TMHeight)
830//    );
831    ReleaseDC(Handle, DC);
832    { GetTextMetrics may not be supported on all devices, so we
833      have fallback to GetSystemMetrics if it doesn't work.
834      Also careful that SM_CYSMCAPTION returns 0 on the emulator }
835    if ORect.Top = 0 then ORect.Top := GetSystemMetrics(SM_CYCAPTION);
836    if ORect.Top = 0 then ORect.Top := 2;
837    // add the left, right and bottom frame borders
838    ORect.Left := 2;
839    ORect.Right := -2;
840    ORect.Bottom := -2;
841  end else
842  if TheWinControl is TCustomTabControl then
843  begin
844    // Can't use complete client rect in wince interface, bottom part contains the tabs
845    Windows.GetClientRect(Handle, @ARect);
846    ORect := ARect;
847    Windows.SendMessage(Handle, TCM_AdjustRect, 0, LPARAM(@ORect));
848    Dec(ORect.Right, ARect.Right);
849    Dec(ORect.Bottom, ARect.Bottom);
850  end;
851
852  {$ifdef DEBUG_WINDOW_ORG}
853  DebugLn(
854    Format('GetLCLClientBoundsOffset Name=%s OLeft=%d OTop=%d ORight=%d OBottom=%d',
855     [TheWinControl.Name, ORect.Left, ORect.Top, ORect.Right, ORect.Bottom]));
856  {$endif}
857
858  Result := True;
859end;
860
861function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
862var
863  OwnerObject: TObject;
864begin
865  OwnerObject := GetWindowInfo(Handle)^.WinControl;
866  Result:=GetLCLClientBoundsOffset(OwnerObject, Rect);
867end;
868
869procedure LCLBoundsToWin32Bounds(Sender: TObject;
870  var Left, Top, Width, Height: Integer);
871var
872  ORect: TRect;
873Begin
874  if (Sender=nil) or (not (Sender is TWinControl)) then exit;
875  if not GetLCLClientBoundsOffset(TWinControl(Sender).Parent, ORect) then exit;
876  inc(Left, ORect.Left);
877  inc(Top, ORect.Top);
878End;
879
880procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer);
881{$NOTE Should be moved to WSWin32Forms, if the windowproc is splitted}
882var
883  SizeRect: Windows.RECT;
884  BorderStyle: TFormBorderStyle;
885begin
886  with SizeRect do
887  begin
888    Left := 0;
889    Top := 0;
890    Right := AWidth;
891    Bottom := AHeight;
892  end;
893  BorderStyle := Form.BorderStyle;
894  Windows.AdjustWindowRectEx(@SizeRect, BorderStyleToWinAPIFlags(
895      BorderStyle), false, BorderStyleToWinAPIFlagsEx(Form, BorderStyle));
896  AWidth := SizeRect.Right - SizeRect.Left;
897  AHeight := SizeRect.Bottom - SizeRect.Top;
898end;
899
900procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
901var
902  parRect, winRect: Windows.TRect;
903begin
904  Windows.GetWindowRect(Window, @winRect);
905  Windows.GetWindowRect(Parent, @parRect);
906  Left := winRect.Left - parRect.Left;
907  Top := winRect.Top - parRect.Top;
908end;
909
910{
911  Updates the window style of the window indicated by Handle.
912  The new style is the Style parameter.
913  Only the bits set in the StyleMask are changed,
914  the other bits remain untouched.
915  If the bits in the StyleMask are not used in the Style,
916  there are cleared.
917}
918procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
919var
920  CurrentStyle,
921  NewStyle : PtrInt;
922begin
923  CurrentStyle := Windows.GetWindowLong(Handle, GWL_STYLE);
924  NewStyle := (Style and StyleMask) or (CurrentStyle and (not StyleMask));
925  Windows.SetWindowLong(Handle, GWL_STYLE, NewStyle);
926end;
927
928function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD;
929begin
930  Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
931  case Application.ApplicationType of
932  { Under Desktop or Handheld mode we get an application which
933    looks similar to a desktop one, with sizable windows }
934    atDesktop:
935      begin
936        case Style of
937        bsSizeable, bsSizeToolWin:
938          Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
939        bsSingle, bsToolWindow:
940          Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
941        bsDialog:
942          Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
943        bsNone:
944          Result := Result or WS_POPUP;
945        end;
946      end;
947    { Under PDA or Smartphone modes most windows are enlarged to fit the screen
948      Dialogs and borderless windows are exceptions }
949    atPDA, atKeyPadDevice, atDefault:
950      begin
951        case Style of
952        bsDialog:
953          Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
954        bsNone:
955          Result := Result or WS_POPUP;
956        else
957          Result := 0; // Never add WS_VISIBLE here, bug http://bugs.freepascal.org/view.php?id=12193
958        end;
959      end;
960  end;
961end;
962
963function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD;
964begin
965  Result := 0;
966
967  case Application.ApplicationType of
968
969    atDesktop:
970    begin
971      case Style of
972      bsDialog:
973        Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
974      bsToolWindow, bsSizeToolWin:
975        Result := WS_EX_TOOLWINDOW;
976      end;
977    end;
978
979    atPDA, atKeyPadDevice, atDefault:
980    begin
981      {$ifdef WinCE}
982      // Adds an "OK" close button to the title bar instead of the standard
983      // "X" minimize button, unless the developer overrides that decision
984      case WinCEWidgetset.WinCETitlePolicy of
985
986        tpAlwaysUseOKButton: Result := WS_EX_CAPTIONOKBTN;
987
988
989        tpControlWithBorderIcons:
990        begin
991          if not (biMinimize in AForm.BorderIcons) then Result := WS_EX_CAPTIONOKBTN;
992        end;
993      else
994        if Style = bsDialog then Result := WS_EX_CAPTIONOKBTN;
995      end;
996      {$endif}
997    end;
998
999  end;
1000end;
1001
1002function GetFileVersion(FileName: string): dword;
1003var
1004  buf: pointer;
1005  lenBuf: dword;
1006  fixedInfo: ^VS_FIXEDFILEINFO;
1007  WideBuffer: widestring;
1008begin
1009  Result := $FFFFFFFF;
1010  WideBuffer := UTF8Decode(FileName);
1011  lenBuf := GetFileVersionInfoSizeW(PWideChar(WideBuffer), lenBuf);
1012  if lenBuf > 0 then
1013  begin
1014    GetMem(buf, lenBuf);
1015    if GetFileVersionInfoW(PWideChar(WideBuffer), 0, lenBuf, buf) then
1016    begin
1017      VerQueryValue(buf, '\', pointer(fixedInfo), lenBuf);
1018      Result := fixedInfo^.dwFileVersionMS;
1019    end;
1020    FreeMem(buf);
1021  end;
1022end;
1023
1024function AllocWindowInfo(Window: HWND): PWindowInfo;
1025var
1026  WindowInfo: PWindowInfo;
1027begin
1028  New(WindowInfo);
1029  FillChar(WindowInfo^, sizeof(WindowInfo^), 0);
1030  WindowInfo^.DrawItemIndex := -1;
1031  {$ifdef win32}
1032  Windows.SetPropW(Window, PWideChar(DWord(WindowInfoAtom)), DWord(WindowInfo));
1033  {$else}
1034  Windows.SetProp(Window, PWideChar(DWord(WindowInfoAtom)), DWord(WindowInfo));
1035  {$endif}
1036  Result := WindowInfo;
1037end;
1038
1039function DisposeWindowInfo(Window: HWND): boolean;
1040var
1041  WindowInfo: PWindowInfo;
1042begin
1043  {$ifdef win32}
1044  WindowInfo := PWindowInfo(Windows.GetPropW(Window, PWideChar(DWord(WindowInfoAtom))));
1045  Result := Windows.RemovePropW(Window, PWideChar(DWord(WindowInfoAtom)))<>0;
1046  {$else}
1047  WindowInfo := PWindowInfo(Windows.GetProp(Window, PWideChar(DWord(WindowInfoAtom))));
1048  Result := Windows.RemoveProp(Window, PWideChar(DWord(WindowInfoAtom)))<>0;
1049  {$endif}
1050  if Result then
1051    Dispose(WindowInfo);
1052end;
1053
1054function GetWindowInfo(Window: HWND): PWindowInfo;
1055begin
1056  {$ifdef win32}
1057  Result := PWindowInfo(Windows.GetPropW(Window, PWideChar(DWord(WindowInfoAtom))));
1058  {$else}
1059  Result := PWindowInfo(Windows.GetProp(Window, PWideChar(DWord(WindowInfoAtom))));
1060  {$endif}
1061  if Result = nil then
1062    Result := @DefaultWindowInfo;
1063end;
1064
1065function WndClassName(Wnd: HWND): String; inline;
1066var
1067  winClassName: array[0..19] of widechar;
1068begin
1069  GetClassName(Wnd, @winClassName, 20);
1070  Result := winClassName;
1071end;
1072
1073function IsAlienWindow(Wnd: HWND): Boolean;
1074
1075const
1076  // list window class names is taken here:
1077  // http://www.pocketpcdn.com/print/articles/?&atb.set(c_id)=51&atb.set(a_id)=7165&atb.perform(details)=
1078  AlienWindowClasses: array[0..7] of String =
1079  (
1080    'menu_worker',        // can be also found by SHFindMenuBar
1081    'MS_SOFTKEY_CE_1.0',  // google about that one. as I understand it related to bottom menu too
1082    'Default Ime',
1083    'Ime',
1084    'static',
1085    'OLEAUT32',
1086    'FAKEIMEUI',
1087    'tooltips_class32'
1088  );
1089
1090var
1091  i: integer;
1092  WndName: String;
1093begin
1094  WndName := WndClassName(Wnd);
1095  Result := False;
1096  for i := Low(AlienWindowClasses) to High(AlienWindowClasses) do
1097    if WndName = AlienWindowClasses[i] then
1098      Exit(True);
1099end;
1100
1101{procedure LogWindow(Window: HWND);
1102begin
1103  DbgAppendToFile(ExtractFilePath(ParamStr(0)) + '1.log',
1104    'Window = ' + IntToStr(Window) + ' ClassName = ' + WndClassName(Window) + ' Thread id = ' + IntToStr(GetWindowThreadProcessId(Window, nil)));
1105end;}
1106
1107function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
1108var
1109  textSize: Windows.SIZE;
1110  winHandle: HWND;
1111  canvasHandle: HDC;
1112  oldFontHandle: HFONT;
1113begin
1114  winHandle := AWinControl.Handle;
1115  canvasHandle := GetDC(winHandle);
1116  oldFontHandle := SelectObject(canvasHandle, Windows.SendMessage(winHandle, WM_GetFont, 0, 0));
1117  DeleteAmpersands(Text);
1118
1119  Result := LCLIntf.GetTextExtentPoint32(canvasHandle, PChar(Text), Length(Text), textSize);
1120
1121  if Result then
1122  begin
1123    Width := textSize.cx;
1124    Height := textSize.cy;
1125  end;
1126  SelectObject(canvasHandle, oldFontHandle);
1127  ReleaseDC(winHandle, canvasHandle);
1128end;
1129
1130function GetControlText(AHandle: HWND): string;
1131var
1132  TextLen: dword;
1133  tmpWideStr : PWideChar;
1134begin
1135  TextLen := GetWindowTextLength(AHandle);
1136  tmpWideStr := PWideChar(SysAllocStringLen(nil,TextLen + 1));
1137  GetWindowTextW(AHandle, tmpWideStr, TextLen + 1);
1138  Result := UTF8Encode(widestring(tmpWideStr));
1139  SysFreeString(tmpWideStr);
1140end;
1141
1142procedure WideStrCopy(Dest, Src: PWideChar);
1143var
1144  counter : longint;
1145Begin
1146  counter := 0;
1147  while Src[counter] <> #0 do
1148  begin
1149    Dest[counter] := Src[counter];
1150    Inc(counter);
1151  end;
1152  Dest[counter] := #0;
1153end;
1154
1155{ Exactly equal to StrLCopy but for PWideChars
1156  Copyes a widestring up to a maximal length, in WideChars }
1157function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
1158var
1159  counter: SizeInt;
1160begin
1161  counter := 0;
1162
1163  while (Source[counter] <> #0)  and (counter < MaxLen) do
1164  begin
1165    Dest[counter] := Source[counter];
1166    Inc(counter);
1167  end;
1168
1169  { terminate the string }
1170  Dest[counter] := #0;
1171  Result := Dest;
1172end;
1173
1174function WideStrCmp(W1, W2: PWideChar): Integer;
1175var
1176  counter: Integer;
1177Begin
1178  counter := 0;
1179  While W1[counter] = W2[counter] do
1180  Begin
1181    if (W2[counter] = #0) or (W1[counter] = #0) then
1182       break;
1183    Inc(counter);
1184  end;
1185  Result := ord(W1[counter]) - ord(W2[counter]);
1186end;
1187
1188function GetWinCEPlatform: TApplicationType;
1189{$ifdef Win32}
1190begin
1191  Result := atDesktop;
1192end;
1193{$else}
1194var
1195  buf: array[0..50] of WideChar;
1196begin
1197  Result := atDefault;
1198
1199  if Windows.SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then
1200  begin
1201    if WideStrCmp(@buf, 'PocketPC') = 0 then
1202      Result := atPDA
1203    else if WideStrCmp(@buf, 'SmartPhone') = 0 then
1204      Result := atKeyPadDevice
1205    else
1206      // Other devices can set anything for the platform name,
1207      // see http://bugs.freepascal.org/view.php?id=16615
1208      // Here we just suppose that they are atDesktop
1209      Result := atDesktop;
1210  end
1211  else if GetLastError = ERROR_ACCESS_DENIED then
1212    Result := atKeyPadDevice
1213  else
1214    Result := atPDA;
1215end;
1216{$endif}
1217
1218function GetWinCEVersion: TWinCEVersion;
1219{$ifdef Win32}
1220begin
1221  Result := wince_other;
1222end;
1223{$else}
1224var
1225  versionInfo: OSVERSIONINFO;
1226begin
1227  Result := wince_other;
1228
1229  System.FillChar(versionInfo, sizeof(OSVERSIONINFO), #0);
1230  versionInfo.dwOSVersionInfoSize := sizeof(OSVERSIONINFO);
1231
1232  if GetVersionEx(@versionInfo) then
1233  begin
1234    case versionInfo.dwMajorVersion of
1235    1: Result := wince_1;
1236    2: Result := Wince_2;
1237    3: Result := Wince_3;
1238    4: Result := Wince_4;
1239    5:
1240    begin
1241      if versionInfo.dwMinorVersion = 2 then Result := Wince_6
1242      else Result := Wince_5;
1243    end;
1244    6: Result := Wince_6;
1245    7: Result := wince_7;
1246    end;
1247  end;
1248end;
1249{$endif}
1250
1251function IsHiResMode: Boolean;
1252begin
1253  {$ifdef Win32}
1254  Result := False;
1255  {$else}
1256  Result := Screen.Width > 240;
1257  {$endif}
1258end;
1259
1260
1261{-------------------------------------------------------------------------------
1262  procedure AddToChangedMenus(Window: HWnd);
1263
1264  Adds Window to the list of windows which need to redraw the main menu.
1265-------------------------------------------------------------------------------}
1266procedure AddToChangedMenus(Window: HWnd);
1267begin
1268  if ChangedMenus.IndexOf(Pointer(Window)) = -1 then // Window handle is not yet in the list
1269    ChangedMenus.Add(Pointer(Window));
1270end;
1271
1272{------------------------------------------------------------------------------
1273  Method: RedrawMenus
1274  Params:  None
1275  Returns: Nothing
1276
1277  Redraws all changed menus
1278 ------------------------------------------------------------------------------}
1279procedure RedrawMenus;
1280var
1281  I: integer;
1282begin
1283  for I := 0 to  ChangedMenus.Count - 1 do
1284    DrawMenuBar(HWND(ChangedMenus[I]));
1285  ChangedMenus.Clear;
1286end;
1287
1288procedure DoInitialization;
1289begin
1290  FillChar(DefaultWindowInfo, sizeof(DefaultWindowInfo), 0);
1291  DefaultWindowInfo.DrawItemIndex := -1;
1292  WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
1293  ChangedMenus := TList.Create;
1294end;
1295
1296procedure DoFinalization;
1297begin
1298  Windows.GlobalDeleteAtom(WindowInfoAtom);
1299  WindowInfoAtom := 0;
1300  ChangedMenus.Free;
1301end;
1302
1303initialization
1304  DoInitialization;
1305
1306finalization
1307  DoFinalization;
1308
1309end.
1310
1311
1312
1313
1314
1315