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