{ ------------------------------ winproc.pp ------------------------------ Misc types and procedures for LCL-CustomDrawn-Windows ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } unit customdrawn_winproc; {$mode objfpc}{$H+} interface uses Windows, CTypes, Classes, SysUtils, // LCL LCLType, Interfacebase, LMessages, lclintf, LCLMessageGlue, LCLProc, Controls, Forms, graphtype, Menus, IntfGraphics, lazcanvas, // customdrawnproc; type MCHITTESTINFO = record cbSize: UINT; pt : TPoint; uHit : UINT; // out param st : SYSTEMTIME; end; TMCMHitTestInfo = MCHITTESTINFO; PMCMHitTestInfo = ^TMCMHitTestInfo; // Window information snapshot tagWINDOWINFO = record cbSize: DWORD; rcWindow: TRect; rcClient: TRect; dwStyle: DWORD; dwExStyle: DWORD; dwWindowStatus: DWORD; cxWindowBorders: UINT; cyWindowBorders: UINT; atomWindowType: ATOM; wCreatorVersion: WORD; end; PTAGWINDOWINFO = ^tagWINDOWINFO; type { lazarus win32 Interface definition for additional timer data needed to find the callback} PWinCETimerInfo = ^TWinCETimerinfo; TWinCETimerInfo = record TimerID: UINT_PTR; // the windows timer ID for this timer TimerFunc: TWSTimerProc; // owner function to handle timer end; {$ifdef WinCE} function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; cdecl; external KernelDLL name 'EnumDisplayMonitors'; function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; cdecl; external KernelDLL name 'GetMonitorInfo'; function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; cdecl; external KernelDLL name 'MonitorFromWindow'; function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromRect'; function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; cdecl; external KernelDLL name 'MonitorFromPoint'; {$else} function EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MONITORENUMPROC; dwData: LPARAM): LongBool; stdcall; external 'user32.dll' name 'EnumDisplayMonitors'; function GetMonitorInfoW(hMonitor: HMONITOR; lpmi: PMonitorInfo): LongBool; stdcall; external 'user32.dll' name 'GetMonitorInfoW'; function MonitorFromWindow(hWnd: HWND; dwFlags: DWORD): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromWindow'; function MonitorFromRect(lprcScreenCoords: PRect; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromRect'; function MonitorFromPoint(ptScreenCoords: TPoint; dwFlags: DWord): HMONITOR; stdcall; external 'user32.dll' name 'MonitorFromPoint'; // from win32extra.pp function GetWindowInfo(hwnd: HWND; pwi: PTAGWINDOWINFO): BOOL; stdcall; external 'user32.dll' name 'GetWindowInfo'; {$endif} type TMouseDownFocusStatus = (mfNone, mfFocusSense, mfFocusChanged); PProcessEvent = ^TProcessEvent; TProcessEvent = record Handle: THandle; Handler: PEventHandler; UserData: PtrInt; OnEvent: TChildExitEvent; end; var // FTimerData contains the currently running timers FTimerData : TList; // list of PWin32Timerinfo MouseDownTime: dword; MouseDownPos: TPoint; MouseDownWindow: HWND = 0; MouseDownFocusWindow: HWND; MouseDownFocusStatus: TMouseDownFocusStatus = mfNone; ComboBoxHandleSizeWindow: HWND = 0;//just do not know the use yet IgnoreNextCharWindow: HWND = 0; // ignore next WM_(SYS)CHAR message OnClipBoardRequest: TClipboardRequestEvent = nil; type TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown); TWindowInfo = class(TCDForm) Overlay: HWND; // overlay, transparent window on top, used by designer //PopupMenu: TPopupMenu; DefWndProc: WNDPROC; ParentPanel: HWND; // if non-zero, is the tabsheet window, for the pagecontrol hack List: TStrings; StayOnTopList: TList; // a list of windows that were normalized when showing modal MaxLength: dword; MouseX, MouseY: word; // noticing spurious WM_MOUSEMOVE messages // CD additions Bitmap: HBITMAP; BitmapWidth: integer; BitmapHeight: integer; BitmapDC, DCBitmapOld: HDC; end; PStayOnTopWindowsInfo = ^TStayOnTopWindowsInfo; TStayOnTopWindowsInfo = record AppHandle: HWND; SystemTopAlso: Boolean; StayOnTopList: TList; end; TWindowsVersion = ( wvUnknown, // wince_1, wince_2, wince_3, wince_4, wince_5, wince_6, wince_6_1, wince_6_5, wince_7, wince_other, // wv95, wvNT4, wv98, wvMe, wv2000, wvXP, wvServer2003, //wvServer2003R2, // has the same major/minor as wvServer2003 wvVista, //wvServer2008, // has the same major/minor as wvVista wv7, wv8, wvLater ); function WM_To_String(WM_Message: Integer): string; function WindowPosFlagsToString(Flags: UINT): string; function ObjectToHWND(Const AObject: TObject): HWND; function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt; function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP; procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription); procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription); function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean; function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean; {$ifndef WinCE} function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP):TRawImageLineOrder; {$endif} function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean; function IsAlphaBitmap(ABitmap: HBITMAP): Boolean; function IsAlphaDC(ADC: HDC): Boolean; function GetLastErrorText(AErrorCode: Cardinal): WideString; function LCLControlSizeNeedsUpdate(Sender: TWinControl; SendSizeMsgOnDiff: boolean): boolean; function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean; function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean; procedure LCLBoundsToWin32Bounds(Sender: TObject; var Left, Top, Width, Height: Integer); procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer); procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer); function GetWindowInfo(AWindow: HWND): TWindowInfo; procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer); function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD; function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD; function GetFileVersion(FileName: string): dword; procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False); procedure RestoreStayOnTopFlags(AppHandle: HWND); procedure AddToChangedMenus(Window: HWnd); procedure RedrawMenus; function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean; function GetControlText(AHandle: HWND): string; { String functions that may be moved to the RTL in the future } procedure WideStrCopy(Dest, Src: PWideChar); function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar; function WideStrCmp(W1, W2: PWideChar): Integer; { Automatic detection of platform } function GetWinCEPlatform: TApplicationType; function IsHiResMode: Boolean; procedure UpdateWindowsVersion; var DefaultWindowInfo: TWindowInfo; WindowInfoAtom: ATOM; OverwriteCheck: Integer = 0; ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn WindowsVersion: TWindowsVersion = wvUnknown; const ClsName: array[0..6] of WideChar = ('W', 'i', 'n', 'd', 'o', 'w', #0); ClsHintName: array[0..10] of WideChar = ('H', 'i', 'n', 't', 'W', 'i', 'n', 'd', 'o', 'w', #0); implementation uses customdrawnint; var InRemoveStayOnTopFlags: Integer = 0; {------------------------------------------------------------------------------ Function: WM_To_String Params: WM_Message - a WinDows message Returns: A WinDows-message name Converts a winDows message identIfier to a string ------------------------------------------------------------------------------} function WM_To_String(WM_Message: Integer): string; Begin Case WM_Message of $0000: Result := 'WM_NULL'; $0001: Result := 'WM_CREATE'; $0002: Result := 'WM_DESTROY'; $0003: Result := 'WM_MOVE'; $0005: Result := 'WM_SIZE'; $0006: Result := 'WM_ACTIVATE'; $0007: Result := 'WM_SETFOCUS'; $0008: Result := 'WM_KILLFOCUS'; $000A: Result := 'WM_ENABLE'; $000B: Result := 'WM_SETREDRAW'; $000C: Result := 'WM_SETTEXT'; $000D: Result := 'WM_GETTEXT'; $000E: Result := 'WM_GETTEXTLENGTH'; $000F: Result := 'WM_PAINT'; $0010: Result := 'WM_CLOSE'; $0011: Result := 'WM_QUERYENDSESSION'; $0012: Result := 'WM_QUIT'; $0013: Result := 'WM_QUERYOPEN'; $0014: Result := 'WM_ERASEBKGND'; $0015: Result := 'WM_SYSCOLORCHANGE'; $0016: Result := 'WM_EndSESSION'; $0017: Result := 'WM_SYSTEMERROR'; $0018: Result := 'WM_SHOWWINDOW'; $0019: Result := 'WM_CTLCOLOR'; $001A: Result := 'WM_WININICHANGE or WM_SETTINGCHANGE'; $001B: Result := 'WM_DEVMODECHANGE'; $001C: Result := 'WM_ACTIVATEAPP'; $001D: Result := 'WM_FONTCHANGE'; $001E: Result := 'WM_TIMECHANGE'; $001F: Result := 'WM_CANCELMODE'; $0020: Result := 'WM_SETCURSOR'; $0021: Result := 'WM_MOUSEACTIVATE'; $0022: Result := 'WM_CHILDACTIVATE'; $0023: Result := 'WM_QUEUESYNC'; $0024: Result := 'WM_GETMINMAXINFO'; $0026: Result := 'WM_PAINTICON'; $0027: Result := 'WM_ICONERASEBKGND'; $0028: Result := 'WM_NEXTDLGCTL'; $002A: Result := 'WM_SPOOLERSTATUS'; $002B: Result := 'WM_DRAWITEM'; $002C: Result := 'WM_MEASUREITEM'; $002D: Result := 'WM_DELETEITEM'; $002E: Result := 'WM_VKEYTOITEM'; $002F: Result := 'WM_CHARTOITEM'; $0030: Result := 'WM_SETFONT'; $0031: Result := 'WM_GETFONT'; $0032: Result := 'WM_SETHOTKEY'; $0033: Result := 'WM_GETHOTKEY'; $0037: Result := 'WM_QUERYDRAGICON'; $0039: Result := 'WM_COMPAREITEM'; $003D: Result := 'WM_GETOBJECT'; $0041: Result := 'WM_COMPACTING'; $0044: Result := 'WM_COMMNOTIFY { obsolete in Win32}'; $0046: Result := 'WM_WINDOWPOSCHANGING'; $0047: Result := 'WM_WINDOWPOSCHANGED'; $0048: Result := 'WM_POWER'; $004A: Result := 'WM_COPYDATA'; $004B: Result := 'WM_CANCELJOURNAL'; $004E: Result := 'WM_NOTIFY'; $0050: Result := 'WM_INPUTLANGCHANGEREQUEST'; $0051: Result := 'WM_INPUTLANGCHANGE'; $0052: Result := 'WM_TCARD'; $0053: Result := 'WM_HELP'; $0054: Result := 'WM_USERCHANGED'; $0055: Result := 'WM_NOTIFYFORMAT'; $007B: Result := 'WM_CONTEXTMENU'; $007C: Result := 'WM_STYLECHANGING'; $007D: Result := 'WM_STYLECHANGED'; $007E: Result := 'WM_DISPLAYCHANGE'; $007F: Result := 'WM_GETICON'; $0080: Result := 'WM_SETICON'; $0081: Result := 'WM_NCCREATE'; $0082: Result := 'WM_NCDESTROY'; $0083: Result := 'WM_NCCALCSIZE'; $0084: Result := 'WM_NCHITTEST'; $0085: Result := 'WM_NCPAINT'; $0086: Result := 'WM_NCACTIVATE'; $0087: Result := 'WM_GETDLGCODE'; $00A0: Result := 'WM_NCMOUSEMOVE'; $00A1: Result := 'WM_NCLBUTTONDOWN'; $00A2: Result := 'WM_NCLBUTTONUP'; $00A3: Result := 'WM_NCLBUTTONDBLCLK'; $00A4: Result := 'WM_NCRBUTTONDOWN'; $00A5: Result := 'WM_NCRBUTTONUP'; $00A6: Result := 'WM_NCRBUTTONDBLCLK'; $00A7: Result := 'WM_NCMBUTTONDOWN'; $00A8: Result := 'WM_NCMBUTTONUP'; $00A9: Result := 'WM_NCMBUTTONDBLCLK'; $0100: Result := 'WM_KEYFIRST or WM_KEYDOWN'; $0101: Result := 'WM_KEYUP'; $0102: Result := 'WM_CHAR'; $0103: Result := 'WM_DEADCHAR'; $0104: Result := 'WM_SYSKEYDOWN'; $0105: Result := 'WM_SYSKEYUP'; $0106: Result := 'WM_SYSCHAR'; $0107: Result := 'WM_SYSDEADCHAR'; $0108: Result := 'WM_KEYLAST'; $010D: Result := 'WM_IME_STARTCOMPOSITION'; $010E: Result := 'WM_IME_ENDCOMPOSITION'; $010F: Result := 'WM_IME_COMPOSITION or WM_IME_KEYLAST'; $0110: Result := 'WM_INITDIALOG'; $0111: Result := 'WM_COMMAND'; $0112: Result := 'WM_SYSCOMMAND'; $0113: Result := 'WM_TIMER'; $0114: Result := 'WM_HSCROLL'; $0115: Result := 'WM_VSCROLL'; $0116: Result := 'WM_INITMENU'; $0117: Result := 'WM_INITMENUPOPUP'; $011F: Result := 'WM_MENUSELECT'; $0120: Result := 'WM_MENUCHAR'; $0121: Result := 'WM_ENTERIDLE'; $0122: Result := 'WM_MENURBUTTONUP'; $0123: Result := 'WM_MENUDRAG'; $0124: Result := 'WM_MENUGETOBJECT'; $0125: Result := 'WM_UNINITMENUPOPUP'; $0126: Result := 'WM_MENUCOMMAND'; $0132: Result := 'WM_CTLCOLORMSGBOX'; $0133: Result := 'WM_CTLCOLOREDIT'; $0134: Result := 'WM_CTLCOLORLISTBOX'; $0135: Result := 'WM_CTLCOLORBTN'; $0136: Result := 'WM_CTLCOLORDLG'; $0137: Result := 'WM_CTLCOLORSCROLLBAR'; $0138: Result := 'WM_CTLCOLORSTATIC'; $0200: Result := 'WM_MOUSEFIRST or WM_MOUSEMOVE'; $0201: Result := 'WM_LBUTTONDOWN'; $0202: Result := 'WM_LBUTTONUP'; $0203: Result := 'WM_LBUTTONDBLCLK'; $0204: Result := 'WM_RBUTTONDOWN'; $0205: Result := 'WM_RBUTTONUP'; $0206: Result := 'WM_RBUTTONDBLCLK'; $0207: Result := 'WM_MBUTTONDOWN'; $0208: Result := 'WM_MBUTTONUP'; $0209: Result := 'WM_MBUTTONDBLCLK'; $020A: Result := 'WM_MOUSEWHEEL or WM_MOUSELAST'; $0210: Result := 'WM_PARENTNOTIFY'; $0211: Result := 'WM_ENTERMENULOOP'; $0212: Result := 'WM_EXITMENULOOP'; $0213: Result := 'WM_NEXTMENU'; $0214: Result := 'WM_SIZING'; $0215: Result := 'WM_CAPTURECHANGED'; $0216: Result := 'WM_MOVING'; $0218: Result := 'WM_POWERBROADCAST'; $0219: Result := 'WM_DEVICECHANGE'; $0220: Result := 'WM_MDICREATE'; $0221: Result := 'WM_MDIDESTROY'; $0222: Result := 'WM_MDIACTIVATE'; $0223: Result := 'WM_MDIRESTORE'; $0224: Result := 'WM_MDINEXT'; $0225: Result := 'WM_MDIMAXIMIZE'; $0226: Result := 'WM_MDITILE'; $0227: Result := 'WM_MDICASCADE'; $0228: Result := 'WM_MDIICONARRANGE'; $0229: Result := 'WM_MDIGETACTIVE'; $0230: Result := 'WM_MDISETMENU'; $0231: Result := 'WM_ENTERSIZEMOVE'; $0232: Result := 'WM_EXITSIZEMOVE'; $0233: Result := 'WM_DROPFILES'; $0234: Result := 'WM_MDIREFRESHMENU'; $0281: Result := 'WM_IME_SETCONTEXT'; $0282: Result := 'WM_IME_NOTIFY'; $0283: Result := 'WM_IME_CONTROL'; $0284: Result := 'WM_IME_COMPOSITIONFULL'; $0285: Result := 'WM_IME_SELECT'; $0286: Result := 'WM_IME_CHAR'; $0288: Result := 'WM_IME_REQUEST'; $0290: Result := 'WM_IME_KEYDOWN'; $0291: Result := 'WM_IME_KEYUP'; $02A1: Result := 'WM_MOUSEHOVER'; $02A3: Result := 'WM_MOUSELEAVE'; $0300: Result := 'WM_CUT'; $0301: Result := 'WM_COPY'; $0302: Result := 'WM_PASTE'; $0303: Result := 'WM_CLEAR'; $0304: Result := 'WM_UNDO'; $0305: Result := 'WM_RENDERFORMAT'; $0306: Result := 'WM_RENDERALLFORMATS'; $0307: Result := 'WM_DESTROYCLIPBOARD'; $0308: Result := 'WM_DRAWCLIPBOARD'; $0309: Result := 'WM_PAINTCLIPBOARD'; $030A: Result := 'WM_VSCROLLCLIPBOARD'; $030B: Result := 'WM_SIZECLIPBOARD'; $030C: Result := 'WM_ASKCBFORMATNAME'; $030D: Result := 'WM_CHANGECBCHAIN'; $030E: Result := 'WM_HSCROLLCLIPBOARD'; $030F: Result := 'WM_QUERYNEWPALETTE'; $0310: Result := 'WM_PALETTEISCHANGING'; $0311: Result := 'WM_PALETTECHANGED'; $0312: Result := 'WM_HOTKEY'; $0317: Result := 'WM_PRINT'; $0318: Result := 'WM_PRINTCLIENT'; $0358: Result := 'WM_HANDHELDFIRST'; $035F: Result := 'WM_HANDHELDLAST'; $0380: Result := 'WM_PENWINFIRST'; $038F: Result := 'WM_PENWINLAST'; $0390: Result := 'WM_COALESCE_FIRST'; $039F: Result := 'WM_COALESCE_LAST'; $03E0: Result := 'WM_DDE_FIRST or WM_DDE_INITIATE'; $03E1: Result := 'WM_DDE_TERMINATE'; $03E2: Result := 'WM_DDE_ADVISE'; $03E3: Result := 'WM_DDE_UNADVISE'; $03E4: Result := 'WM_DDE_ACK'; $03E5: Result := 'WM_DDE_DATA'; $03E6: Result := 'WM_DDE_REQUEST'; $03E7: Result := 'WM_DDE_POKE'; $03E8: Result := 'WM_DDE_EXECUTE or WM_DDE_LAST'; $0400: Result := 'WM_USER'; $8000: Result := 'WM_APP'; Else Result := 'Unknown(' + IntToStr(WM_Message) + ')'; End; {Case} End; function WindowPosFlagsToString(Flags: UINT): string; var FlagsStr: string; begin FlagsStr := ''; if (Flags and SWP_DRAWFRAME) <> 0 then FlagsStr := FlagsStr + '|SWP_DRAWFRAME'; if (Flags and SWP_HIDEWINDOW) <> 0 then FlagsStr := FlagsStr + '|SWP_HIDEWINDOW'; if (Flags and SWP_NOACTIVATE) <> 0 then FlagsStr := FlagsStr + '|SWP_NOACTIVATE'; if (Flags and SWP_NOCOPYBITS) <> 0 then FlagsStr := FlagsStr + '|SWP_NOCOPYBITS'; if (Flags and SWP_NOMOVE) <> 0 then FlagsStr := FlagsStr + '|SWP_NOMOVE'; if (Flags and SWP_NOOWNERZORDER) <> 0 then FlagsStr := FlagsStr + '|SWP_NOOWNERZORDER'; if (Flags and SWP_NOREDRAW) <> 0 then FlagsStr := FlagsStr + '|SWP_NOREDRAW'; if (Flags and SWP_NOSENDCHANGING) <> 0 then FlagsStr := FlagsStr + '|SWP_NOSENDCHANGING'; if (Flags and SWP_NOSIZE) <> 0 then FlagsStr := FlagsStr + '|SWP_NOSIZE'; if (Flags and SWP_NOZORDER) <> 0 then FlagsStr := FlagsStr + '|SWP_NOZORDER'; if (Flags and SWP_SHOWWINDOW) <> 0 then FlagsStr := FlagsStr + '|SWP_SHOWWINDOW'; if Length(FlagsStr) > 0 then FlagsStr := Copy(FlagsStr, 2, Length(FlagsStr)-1); Result := FlagsStr; end; {------------------------------------------------------------------------------ Procedure: GetWin32KeyInfo Params: Event - Requested info KeyCode - the ASCII key code of the eventkey VirtualKey - the virtual key code of the eventkey SysKey - True If the key is a syskey ExtEnded - True If the key is an extended key Toggle - True If the key is a toggle key and its value is on Returns: Nothing GetWin32KeyInfo returns information about the given key event ------------------------------------------------------------------------------} { procedure GetWin32KeyInfo(const Event: Integer; var KeyCode, VirtualKey: Integer; var SysKey, Extended, Toggle: Boolean); Const MVK_UNIFY_SIDES = 1; Begin //DebugLn('TRACE:Using function GetWin32KeyInfo which isn''t implemented yet'); KeyCode := Word(Event); VirtualKey := MapVirtualKey(KeyCode, MVK_UNIFY_SIDES); SysKey := (VirtualKey = VK_SHIFT) Or (VirtualKey = VK_CONTROL) Or (VirtualKey = VK_MENU); 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); Toggle := Lo(GetKeyState(VirtualKey)) = 1; End; } {------------------------------------------------------------------------------ Function: ObjectToHWND Params: AObject - An LCL Object Returns: The Window handle of the given object Returns the Window handle of the given object, 0 if no object available ------------------------------------------------------------------------------} function ObjectToHWND(Const AObject: TObject): HWND; Var Handle: HWND; Begin Handle:=0; If not assigned(AObject) Then Begin Assert (False, 'TRACE:[ObjectToHWND] Object not assigned'); End Else If (AObject Is TWinControl) Then Begin If TWinControl(AObject).HandleAllocated Then Handle := TWinControl(AObject).Handle End Else If (AObject Is TMenuItem) Then Begin If TMenuItem(AObject).HandleAllocated Then Handle := TMenuItem(AObject).Handle End Else If (AObject Is TMenu) Then Begin If TMenu(AObject).HandleAllocated Then Handle := TMenu(AObject).Items.Handle End // Else If (AObject Is TCommonDialog) Then // Begin // {If TCommonDialog(AObject).HandleAllocated Then } // Handle := TCommonDialog(AObject).Handle // End Else Begin //DebugLn(Format('Trace:[ObjectToHWND] Message received With unhandled class-type <%s>', [AObject.ClassName])); End; Result := Handle; If Handle = 0 Then Assert (False, 'Trace:[ObjectToHWND]****** Warning: handle = 0 *******'); end; function BytesPerLine(nWidth, nBitsPerPixel: Integer): PtrUInt; begin Result := ((nWidth * nBitsPerPixel + 31) and (not 31) ) div 8; end; procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription); begin case ADesc.BitsPerPixel of 1,4,8: begin // palette mode, no offsets ADesc.Format := ricfGray; ADesc.RedPrec := ADesc.BitsPerPixel; ADesc.GreenPrec := 0; ADesc.BluePrec := 0; ADesc.RedShift := 0; ADesc.GreenShift := 0; ADesc.BlueShift := 0; end; 16: begin // 5-6-5 mode //roozbeh all changed from 5-5-5 to 5-6-5 ADesc.RedPrec := 5; ADesc.GreenPrec := 6; ADesc.BluePrec := 5; ADesc.RedShift := 11; ADesc.GreenShift := 5; ADesc.BlueShift := 0; ADesc.Depth := 16; end; 24: begin // 8-8-8 mode ADesc.RedPrec := 8; ADesc.GreenPrec := 8; ADesc.BluePrec := 8; ADesc.RedShift := 16; ADesc.GreenShift := 8; ADesc.BlueShift := 0; end; else // 32: // 8-8-8-8 mode, high byte can be native alpha or custom 1bit maskalpha ADesc.AlphaPrec := 8; ADesc.RedPrec := 8; ADesc.GreenPrec := 8; ADesc.BluePrec := 8; ADesc.AlphaShift := 24; ADesc.RedShift := 16; ADesc.GreenShift := 8; ADesc.BlueShift := 0; ADesc.Depth := 32; end; end; procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription); begin ADesc.Init; ADesc.Format := ricfRGBA; ADesc.Depth := ABitmapInfo.bmBitsPixel; // used bits per pixel ADesc.Width := ABitmapInfo.bmWidth; ADesc.Height := ABitmapInfo.bmHeight; ADesc.BitOrder := riboReversedBits; ADesc.ByteOrder := riboLSBFirst; ADesc.LineOrder := riloTopToBottom; ADesc.BitsPerPixel := ABitmapInfo.bmBitsPixel; // bits per pixel. can be greater than Depth. ADesc.LineEnd := rileDWordBoundary; if ABitmapInfo.bmBitsPixel <= 8 then begin // each pixel is an index in the palette // TODO, ColorCount ADesc.PaletteColorCount := 0; end else ADesc.PaletteColorCount := 0; FillRawImageDescriptionColors(ADesc); ADesc.MaskBitsPerPixel := 1; ADesc.MaskShift := 0; ADesc.MaskLineEnd := rileWordBoundary; // CreateBitmap requires word boundary ADesc.MaskBitOrder := riboReversedBits; end; function WinProc_RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect = nil): Boolean; var WinDIB: Windows.TDIBSection; WinBmp: Windows.TBitmap absolute WinDIB.dsBm; ASize: Integer; R: TRect; begin ARawImage.Init; FillChar(WinDIB, SizeOf(WinDIB), 0); ASize := Windows.GetObject(ABitmap, SizeOf(WinDIB), @WinDIB); if ASize = 0 then Exit(False); //DbgDumpBitmap(ABitmap, 'FromBitmap - Image'); //DbgDumpBitmap(AMask, 'FromMask - Mask'); FillRawImageDescription(WinBmp, ARawImage.Description); // if it is not DIB then alpha in bitmaps is not supported => use 0 alpha prec if ASize < SizeOf(WinDIB) then ARawImage.Description.AlphaPrec := 0; if ARect = nil then begin R := Rect(0, 0, WinBmp.bmWidth, WinBmp.bmHeight); end else begin R := ARect^; if R.Top > WinBmp.bmHeight then R.Top := WinBmp.bmHeight; if R.Bottom > WinBmp.bmHeight then R.Bottom := WinBmp.bmHeight; if R.Left > WinBmp.bmWidth then R.Left := WinBmp.bmWidth; if R.Right > WinBmp.bmWidth then R.Right := WinBmp.bmWidth; end; ARawImage.Description.Width := R.Right - R.Left; ARawImage.Description.Height := R.Bottom - R.Top; // copy bitmap Result := GetBitmapBytes(WinBmp, ABitmap, R, ARawImage.Description.LineEnd, ARawImage.Description.LineOrder, ARawImage.Data, ARawImage.DataSize); // check mask if AMask <> 0 then begin if Windows.GetObject(AMask, SizeOf(WinBmp), @WinBmp) = 0 then Exit(False); Result := GetBitmapBytes(WinBmp, AMask, R, ARawImage.Description.MaskLineEnd, ARawImage.Description.LineOrder, ARawImage.Mask, ARawImage.MaskSize); end else begin ARawImage.Description.MaskBitsPerPixel := 0; end; end; {------------------------------------------------------------------------------ Function: RawImage_CreateBitmaps Params: ARawImage: ABitmap: AMask: ASkipMask: When set there is no mask created Returns: ------------------------------------------------------------------------------} {$ifdef WinCE} function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean; var ADesc: TRawImageDescription absolute ARawImage.Description; DC: HDC; BitsPtr: Pointer; DataSize: PtrUInt; begin Result := False; AMask := 0; if not ((ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary)) then begin DC := Windows.GetDC(0); AMask := 0; ABitmap := CreateDIBSectionFromDescription(DC, ADesc, BitsPtr); //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image'); Windows.ReleaseDC(0, DC); Result := ABitmap <> 0; if not Result then Exit; if BitsPtr = nil then Exit; // copy the image data DataSize := BytesPerLine(ADesc.Width, ADesc.BitsPerPixel) * ADesc.Height; if DataSize > ARawImage.DataSize then DataSize := ARawImage.DataSize; Move(ARawImage.Data^, BitsPtr^, DataSize); end else ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data); if ASkipMask then Exit(True); AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask); //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Mask'); Result := AMask <> 0; end; {$else} function WinProc_RawImage_CreateBitmaps(const ARawImage: TRawImage; out ABitmap, AMask: HBitmap; ASkipMask: Boolean): Boolean; var ADesc: TRawImageDescription absolute ARawImage.Description; function DoBitmap: Boolean; var DC: HDC; Info: record Header: Windows.TBitmapInfoHeader; Colors: array[0..1] of Cardinal; // reserve extra color for mono bitmaps end; DstLinePtr, SrcLinePtr: PByte; SrcPixelPtr, DstPixelPtr: PByte; DstLineSize, SrcLineSize: PtrUInt; x, y: Integer; Ridx, Gidx, Bidx, Aidx, Align, SrcBytes, DstBpp: Byte; begin if (ADesc.BitsPerPixel = 1) and (ADesc.LineEnd = rileWordBoundary) then begin // default BW, word aligned bitmap ABitmap := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Data); Exit(ABitmap <> 0); end; // for 24 bits images, BPP can be 24 or 32 // 32 shouldn't be use since we don't fill the alpha channel if ADesc.Depth = 24 then DstBpp := 24 else DstBpp := ADesc.BitsPerPixel; FillChar(Info, SizeOf(Info), 0); Info.Header.biSize := SizeOf(Info.Header); Info.Header.biWidth := ADesc.Width; if ADesc.LineOrder = riloTopToBottom then Info.Header.biHeight := -ADesc.Height // create top to bottom else Info.Header.biHeight := ADesc.Height; // create bottom to top Info.Header.biPlanes := 1; Info.Header.biBitCount := DstBpp; Info.Header.biCompression := BI_RGB; {Info.Header.biSizeImage := 0;} { first color is black, second color is white, for monochrome bitmap } Info.Colors[1] := $FFFFFFFF; DC := Windows.GetDC(0); // Use createDIBSection, since only devicedepth bitmaps can be selected into a DC // when they are created with createDIBitmap // ABitmap := Windows.CreateDIBitmap(DC, Info.Header, CBM_INIT, ARawImage.Data, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS); ABitmap := Windows.CreateDIBSection(DC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, DstLinePtr, 0, 0); Windows.ReleaseDC(0, DC); if ABitmap = 0 then begin DebugLn('Windows.CreateDIBSection returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError)); Exit(False); end; if DstLinePtr = nil then Exit(False); DstLineSize := Windows.MulDiv(DstBpp, ADesc.Width, 8); // align to DWord Align := DstLineSize and 3; if Align > 0 then Inc(DstLineSize, 4 - Align); SrcLinePtr := ARawImage.Data; SrcLineSize := ADesc.BytesPerLine; // copy the image data if ADesc.Depth >= 24 then begin // check if a pixel copy is needed // 1) Windows uses alpha channel in 32 bpp modes, despite documentation statement that it is ignored. Tested under Windows XP SP3 // Wine also relies on this undocumented behaviour! // So, we need to cut unused A-channel, otherwise we would get black image // // 2) incompatible channel order ADesc.GetRGBIndices(Ridx, Gidx, Bidx, Aidx); if ((ADesc.BitsPerPixel = 32) and (ADesc.Depth = 24)) or (Bidx <> 0) or (Gidx <> 1) or (Ridx <> 2) then begin // copy pixels SrcBytes := ADesc.BitsPerPixel div 8; for y := 0 to ADesc.Height - 1 do begin DstPixelPtr := DstLinePtr; SrcPixelPtr := SrcLinePtr; for x := 0 to ADesc.Width - 1 do begin DstPixelPtr[0] := SrcPixelPtr[Bidx]; DstPixelPtr[1] := SrcPixelPtr[Gidx]; DstPixelPtr[2] := SrcPixelPtr[Ridx]; Inc(DstPixelPtr, 3); //move to the next dest RGB triple Inc(SrcPixelPtr, SrcBytes); end; Inc(DstLinePtr, DstLineSize); Inc(SrcLinePtr, SrcLineSize); end; Exit(True); end; end; // no pixelcopy needed // check if we can move using one call if ADesc.LineEnd = rileDWordBoundary then begin Move(SrcLinePtr^, DstLinePtr^, DstLineSize * ADesc.Height); Exit(True); end; //Can't use just one move, as different alignment for y := 0 to ADesc.Height - 1 do begin Move(SrcLinePtr^, DstLinePtr^, DstLineSize); Inc(DstLinePtr, DstLineSize); Inc(SrcLinePtr, SrcLineSize); end; Result := True; end; begin AMask := 0; Result := DoBitmap; if not Result then Exit; //DbgDumpBitmap(ABitmap, 'CreateBitmaps - Image'); if ASkipMask then Exit; AMask := Windows.CreateBitmap(ADesc.Width, ADesc.Height, 1, 1, ARawImage.Mask); if AMask = 0 then DebugLn('Windows.CreateBitmap returns 0. Reason = ' + GetLastErrorText(Windows.GetLastError)); Result := AMask <> 0; //DbgDumpBitmap(AMask, 'CreateBitmaps - Mask'); end; {$endif} function CreateDIBSectionFromDescription(ADC: HDC; const ADesc: TRawImageDescription; out ABitsPtr: Pointer): HBITMAP; function GetMask(APrec, AShift: Byte): Cardinal; begin Result := ($FFFFFFFF shr (32-APrec)) shl AShift; end; var Info: record Header: Windows.TBitmapInfoHeader; Colors: array[0..3] of Cardinal; // reserve extra color for colormasks end; begin FillChar(Info, sizeof(Info), 0); Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader); Info.Header.biWidth := ADesc.Width; Info.Header.biHeight := -ADesc.Height; Info.Header.biPlanes := 1; Info.Header.biBitCount := ADesc.BitsPerPixel; // TODO: palette support Info.Header.biClrUsed := 0; Info.Header.biClrImportant := 0; Info.Header.biSizeImage := BytesPerLine(Info.Header.biWidth, Info.Header.biBitCount) * ADesc.Height; // CE only supports bitfields if ADesc.BitsPerPixel > 8 then Info.Header.biCompression := BI_BITFIELDS else Info.Header.biCompression := BI_RGB; if ADesc.BitsPerPixel = 1 then begin // mono bitmap: first color is black, second is white Info.Colors[1] := $FFFFFFFF; end else begin // when 24bpp, CE only supports B8G8R8 encoding // TODO: check the description Info.Colors[0] := GetMask(ADesc.RedPrec, ADesc.RedShift); Info.Colors[1] := GetMask(ADesc.GreenPrec, ADesc.GreenShift); Info.Colors[2] := GetMask(ADesc.BluePrec, ADesc.BlueShift); end; // Use createDIBSection, since only devicedepth bitmaps can be selected into a DC // when they are created with createDIBitmap Result := Windows.CreateDIBSection(ADC, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS, ABitsPtr, 0, 0); //DbgDumpBitmap(Result, 'CreateDIBSectionFromDescription - Image'); end; function CreateDIBSectionFromDDB(ASource: HBitmap; out ABitsPtr: Pointer): HBitmap; var ADC, SrcDC, DstDC: HDC; ADesc: TRawImageDescription; SrcOldBm, DstOldBm: HBitmap; begin Result := 0; // get source bitmap description if not RawImage_DescriptionFromBitmap(ASource, ADesc) then Exit; // create apropriate dib section ADC := GetDC(0); Result := CreateDIBSectionFromDescription(ADC, ADesc, ABitsPtr); ReleaseDC(0, ADC); if Result = 0 then Exit; // copy source bitmap into destination SrcDC := CreateCompatibleDC(0); SrcOldBm := SelectObject(SrcDC, ASource); DstDC := CreateCompatibleDC(0); DstOldBm := SelectObject(DstDC, Result); Windows.BitBlt(DstDC, 0, 0, ADesc.Width, ADesc.Height, SrcDC, 0, 0, SRCCOPY); SelectObject(SrcDC, SrcOldBm); SelectObject(DstDC, DstOldBm); DeleteDC(SrcDC); DeleteDC(DstDC); end; {$ifndef Wince} function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP): TRawImageLineOrder; procedure DbgLog(const AFunc: String); begin DebugLn('GetBitmapOrder - GetDIBits ', AFunc, ' failed: ', GetLastErrorText(Windows.GetLastError)); end; var SrcPixel: PCardinal absolute AWinBmp.bmBits; OrgPixel, TstPixel: Cardinal; Scanline: Pointer; DC: HDC; Info: record Header: Windows.TBitmapInfoHeader; Colors: array[Byte] of Cardinal; // reserve extra color for colormasks end; FullScanLine: Boolean; // win9x requires a full scanline to be retrieved // others won't fail when one pixel is requested begin if AWinBmp.bmBits = nil then begin // no DIBsection so always bottom-up Exit(riloBottomToTop); end; // try to figure out the orientation of the given bitmap. // Unfortunately MS doesn't provide a direct function for this. // So modify the first pixel to see if it changes. This pixel is always part // of the first scanline of the given bitmap. // When we request the data through GetDIBits as bottom-up, windows adjusts // the data when it is a top-down. So if the pixel doesn't change the bitmap // was internally a top-down image. FullScanLine := Win32Platform = VER_PLATFORM_WIN32_WINDOWS; if FullScanLine then ScanLine := GetMem(AWinBmp.bmWidthBytes); FillChar(Info.Header, sizeof(Windows.TBitmapInfoHeader), 0); Info.Header.biSize := sizeof(Windows.TBitmapInfoHeader); DC := Windows.GetDC(0); if Windows.GetDIBits(DC, ABitmap, 0, 1, nil, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0 then begin DbgLog('Getinfo'); // failed ??? Windows.ReleaseDC(0, DC); Exit(riloBottomToTop); end; // Get only 1 pixel (or full scanline for win9x) OrgPixel := 0; if FullScanLine then begin if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0 then DbgLog('OrgPixel') else OrgPixel := PCardinal(ScanLine)^; end else begin Info.Header.biWidth := 1; if Windows.GetDIBits(DC, ABitmap, 0, 1, @OrgPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0 then DbgLog('OrgPixel'); end; // modify pixel SrcPixel^ := not SrcPixel^; // get test TstPixel := 0; if FullScanLine then begin if Windows.GetDIBits(DC, ABitmap, 0, 1, ScanLine, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0 then DbgLog('TstPixel') else TstPixel := PCardinal(ScanLine)^; end else begin if Windows.GetDIBits(DC, ABitmap, 0, 1, @TstPixel, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) = 0 then DbgLog('TstPixel'); end; if OrgPixel = TstPixel then Result := riloTopToBottom else Result := riloBottomToTop; // restore pixel & cleanup SrcPixel^ := not SrcPixel^; Windows.ReleaseDC(0, DC); if FullScanLine then FreeMem(Scanline); end; {$endif} {$ifdef WinCE} //function GetBitmapBytes(ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; var AData: Pointer; var ADataSize: PtrUInt): Boolean; function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean; var Section: Windows.TDIBSection; DIBCopy: HBitmap; DIBData: Pointer; begin Result := False; // first try if the bitmap is created as section if (Windows.GetObject(ABitmap, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil) then begin with Section.dsBm do Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize); Exit; end; // bitmap is not a section, retrieve only bitmap if Windows.GetObject(ABitmap, SizeOf(Section.dsBm), @Section) = 0 then Exit; DIBCopy := CreateDIBSectionFromDDB(ABitmap, DIBData); if DIBCopy = 0 then Exit; if (Windows.GetObject(DIBCopy, SizeOf(Section), @Section) > 0) and (Section.dsBm.bmBits <> nil) then begin with Section.dsBm do Result := CopyImageData(bmWidth, bmHeight, bmWidthBytes, bmBitsPixel, bmBits, ARect, riloTopToBottom, riloTopToBottom, ALineEnd, AData, ADataSize); end; DeleteObject(DIBCopy); Result := True; end; {$else} function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect: TRect; ALineEnd: TRawImageLineEnd; ALineOrder: TRawImageLineOrder; out AData: Pointer; out ADataSize: PtrUInt): Boolean; var DC: HDC; Info: record Header: Windows.TBitmapInfoHeader; Colors: array[Byte] of TRGBQuad; // reserve extra colors for palette (256 max) end; H: Cardinal; R: TRect; SrcData: PByte; SrcSize: PtrUInt; SrcLineBytes: Cardinal; SrcLineOrder: TRawImageLineOrder; StartScan: Integer; begin SrcLineOrder := GetBitmapOrder(AWinBmp, ABitmap); SrcLineBytes := (AWinBmp.bmWidthBytes + 3) and not 3; if AWinBmp.bmBits <> nil then begin // this is bitmapsection data :) we can just copy the bits // We cannot trust windows with bmWidthBytes. Use SrcLineBytes which takes // DWORD alignment into consideration with AWinBmp do Result := CopyImageData(bmWidth, bmHeight, SrcLineBytes, bmBitsPixel, bmBits, ARect, SrcLineOrder, ALineOrder, ALineEnd, AData, ADataSize); Exit; end; // retrieve the data though GetDIBits // initialize bitmapinfo structure Info.Header.biSize := sizeof(Info.Header); Info.Header.biPlanes := 1; Info.Header.biBitCount := AWinBmp.bmBitsPixel; Info.Header.biCompression := BI_RGB; Info.Header.biSizeImage := 0; Info.Header.biWidth := AWinBmp.bmWidth; H := ARect.Bottom - ARect.Top; // request a top-down DIB if AWinBmp.bmHeight > 0 then begin Info.Header.biHeight := -AWinBmp.bmHeight; StartScan := AWinBmp.bmHeight - ARect.Bottom; end else begin Info.Header.biHeight := AWinBmp.bmHeight; StartScan := ARect.Top; end; // adjust height if StartScan < 0 then begin Inc(H, StartScan); StartScan := 0; end; // alloc buffer SrcSize := SrcLineBytes * H; GetMem(SrcData, SrcSize); DC := Windows.GetDC(0); Result := Windows.GetDIBits(DC, ABitmap, StartScan, H, SrcData, Windows.PBitmapInfo(@Info)^, DIB_RGB_COLORS) <> 0; Windows.ReleaseDC(0, DC); // since we only got the needed scanlines, adjust top and bottom R.Left := ARect.Left; R.Top := 0; R.Right := ARect.Right; R.Bottom := H; with Info.Header do Result := Result and CopyImageData(biWidth, H, SrcLineBytes, biBitCount, SrcData, R, riloTopToBottom, ALineOrder, ALineEnd, AData, ADataSize); FreeMem(SrcData); end; {$endif} function IsAlphaBitmap(ABitmap: HBITMAP): Boolean; var Info: Windows.BITMAP; begin FillChar(Info, SizeOf(Info), 0); Result := (GetObject(ABitmap, SizeOf(Info), @Info) <> 0) and (Info.bmBitsPixel = 32); end; function IsAlphaDC(ADC: HDC): Boolean; begin Result := (GetObjectType(ADC) = OBJ_MEMDC) and IsAlphaBitmap(GetCurrentObject(ADC, OBJ_BITMAP)); end; function GetLastErrorText(AErrorCode: Cardinal): WideString; var r: cardinal; tmp: PWideChar; begin tmp := nil; r := Windows.FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, AErrorCode, LANG_NEUTRAL, @tmp, 0, nil); if r = 0 then Exit(''); Result := tmp; SetLength(Result, Length(Result)-2); if tmp <> nil then LocalFree(HLOCAL(tmp)); end; (*********************************************************************** Widget member Functions ************************************************************************) {------------------------------------------------------------------------------- function LCLBoundsNeedsUpdate(Sender: TWinControl; SendSizeMsgOnDiff: boolean): boolean; Returns true if LCL bounds and win32 bounds differ for the control. -------------------------------------------------------------------------------} function LCLControlSizeNeedsUpdate(Sender: TWinControl; SendSizeMsgOnDiff: boolean): boolean; var Window:HWND; LMessage: TLMSize; IntfWidth, IntfHeight: integer; begin Result:=false; Window:= Sender.Handle; LCLIntf.GetWindowSize(Window, IntfWidth, IntfHeight); if (Sender.Width = IntfWidth) and (Sender.Height = IntfHeight) and (not Sender.ClientRectNeedsInterfaceUpdate) then exit; Result:=true; if SendSizeMsgOnDiff then begin //writeln('LCLBoundsNeedsUpdate B ',TheWinControl.Name,':',TheWinControl.ClassName,' Sending WM_SIZE'); Sender.InvalidateClientRectCache(true); // send message directly to LCL, some controls not subclassed -> message // never reaches LCL with LMessage do begin Msg := LM_SIZE; SizeType := SIZE_RESTORED or Size_SourceIsInterface; Width := IntfWidth; Height := IntfHeight; end; DeliverMessage(Sender, LMessage); end; end; {------------------------------------------------------------------------------- function GetLCLClientOriginOffset(Sender: TObject; var LeftOffset, TopOffset: integer): boolean; Returns the difference between the client origin of a win32 handle and the definition of the LCL counterpart. For example: TGroupBox's client area is the area inside the groupbox frame. Hence, the LeftOffset is the frame width and the TopOffset is the caption height. -------------------------------------------------------------------------------} function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean; var TM: TextMetric; DC: HDC; Handle: HWND; TheWinControl: TWinControl; ARect: TRect; Ignore: Integer; begin Result:=false; if (Sender = nil) or (not (Sender is TWinControl)) then exit; TheWinControl:=TWinControl(Sender); FillChar(ORect, SizeOf(ORect), 0); if not TheWinControl.HandleAllocated then exit; Handle := TheWinControl.Handle; if TheWinControl is TScrollingWinControl then with TScrollingWinControl(TheWinControl) do begin if HorzScrollBar <> nil then begin // left and right bounds are shifted by scroll position ORect.Left := -HorzScrollBar.Position; ORect.Right := -HorzScrollBar.Position; end; if VertScrollBar <> nil then begin // top and bottom bounds are shifted by scroll position ORect.Top := -VertScrollBar.Position; ORect.Bottom := -VertScrollBar.Position; end; end; {$ifdef DEBUG_WINDOW_ORG} DebugLn( Format('GetLCLClientBoundsOffset Name=%s OLeft=%d OTop=%d ORight=%d OBottom=%d', [TheWinControl.Name, ORect.Left, ORect.Top, ORect.Right, ORect.Bottom])); {$endif} Result := True; end; function GetLCLClientBoundsOffset(Handle: TWindowInfo; var Rect: TRect): boolean; var OwnerObject: TObject; begin OwnerObject := TWindowInfo(Handle).LCLForm; Result:=GetLCLClientBoundsOffset(OwnerObject, Rect); end; procedure LCLBoundsToWin32Bounds(Sender: TObject; var Left, Top, Width, Height: Integer); var ORect: TRect; Begin if (Sender=nil) or (not (Sender is TWinControl)) then exit; if not GetLCLClientBoundsOffset(TWinControl(Sender).Parent, ORect) then exit; inc(Left, ORect.Left); inc(Top, ORect.Top); End; procedure LCLFormSizeToWin32Size(Form: TCustomForm; var AWidth, AHeight: Integer); {$NOTE Should be moved to WSWin32Forms, if the windowproc is splitted} var SizeRect: Windows.RECT; BorderStyle: TFormBorderStyle; begin with SizeRect do begin Left := 0; Top := 0; Right := AWidth; Bottom := AHeight; end; BorderStyle := Form.BorderStyle; Windows.AdjustWindowRectEx(@SizeRect, BorderStyleToWinAPIFlags( BorderStyle), false, BorderStyleToWinAPIFlagsEx(Form, BorderStyle)); AWidth := SizeRect.Right - SizeRect.Left; AHeight := SizeRect.Bottom - SizeRect.Top; end; procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer); var parRect, winRect: Windows.TRect; begin Windows.GetWindowRect(Window, @winRect); Windows.GetWindowRect(Parent, @parRect); Left := winRect.Left - parRect.Left; Top := winRect.Top - parRect.Top; end; function GetWindowInfo(AWindow: HWND): TWindowInfo; begin Result := TWindowInfo(FindFormWithNativeHandle(AWindow)); if Result = nil then Result := DefaultWindowInfo; end; { Updates the window style of the window indicated by Handle. The new style is the Style parameter. Only the bits set in the StyleMask are changed, the other bits remain untouched. If the bits in the StyleMask are not used in the Style, there are cleared. } procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer); var CurrentStyle, NewStyle : PtrInt; begin CurrentStyle := Windows.GetWindowLong(Handle, GWL_STYLE); NewStyle := (Style and StyleMask) or (CurrentStyle and (not StyleMask)); Windows.SetWindowLong(Handle, GWL_STYLE, NewStyle); end; function BorderStyleToWinAPIFlags(Style: TFormBorderStyle): DWORD; begin Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS; case Application.ApplicationType of { Under Desktop or Handheld mode we get an application which looks similar to a desktop one, with sizable windows } atDesktop: begin case Style of bsSizeable, bsSizeToolWin: Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION); bsSingle, bsToolWindow: Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION); bsDialog: Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION); bsNone: Result := Result or WS_POPUP; end; end; { Under PDA or Smartphone modes most windows are enlarged to fit the screen Dialogs and borderless windows are exceptions } atPDA, atKeyPadDevice, atDefault: begin case Style of bsDialog: Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION); bsNone: Result := Result or WS_POPUP; else Result := 0; // Never add WS_VISIBLE here, bug http://bugs.freepascal.org/view.php?id=12193 end; end; end; end; function BorderStyleToWinAPIFlagsEx(AForm: TCustomForm; Style: TFormBorderStyle): DWORD; begin Result := 0; case Application.ApplicationType of atDesktop: begin case Style of bsDialog: Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; bsToolWindow, bsSizeToolWin: Result := WS_EX_TOOLWINDOW; end; end; atPDA, atKeyPadDevice, atDefault: begin {$ifdef WinCE} // Adds an "OK" close button to the title bar instead of the standard // "X" minimize button, unless the developer overrides that decision case CDWidgetSet.WinCETitlePolicy of tpAlwaysUseOKButton: Result := WS_EX_CAPTIONOKBTN; tpControlWithBorderIcons: begin if not (biMinimize in AForm.BorderIcons) then Result := WS_EX_CAPTIONOKBTN; end; else if Style = bsDialog then Result := WS_EX_CAPTIONOKBTN; end; {$endif} end; end; end; function GetFileVersion(FileName: string): dword; var buf: pointer; lenBuf: dword; fixedInfo: ^VS_FIXEDFILEINFO; WideBuffer: widestring; begin Result := $FFFFFFFF; WideBuffer := UTF8Decode(FileName); lenBuf := GetFileVersionInfoSizeW(PWideChar(WideBuffer), lenBuf); if lenBuf > 0 then begin GetMem(buf, lenBuf); if GetFileVersionInfoW(PWideChar(WideBuffer), 0, lenBuf, buf) then begin VerQueryValue(buf, '\', pointer(fixedInfo), lenBuf); Result := fixedInfo^.dwFileVersionMS; end; FreeMem(buf); end; end; function EnumStayOnTopRemove(Handle: HWND; Param: LPARAM): WINBOOL; stdcall; var StayOnTopWindowsInfo: PStayOnTopWindowsInfo absolute Param; lWindowInfo: TWindowInfo; lWinControl: TWinControl; begin { Result := True; if ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0) then begin // Don't remove system-wide stay on top, unless desired if not StayOnTopWindowsInfo^.SystemTopAlso then begin lWindowInfo := TWindowInfo(FindFormWithNativeHandle(Handle)); if Assigned(lWindowInfo) then begin lWinControl := lWindowInfo.LCLForm; if (lWinControl is TCustomForm) and (TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then Exit; end; end; StayOnTopWindowsInfo^.StayOnTopList.Add(Pointer(Handle)); end;} end; procedure RemoveStayOnTopFlags(AppHandle: HWND; ASystemTopAlso: Boolean = False); var StayOnTopWindowsInfo: PStayOnTopWindowsInfo; WindowInfo: TWindowInfo; I: Integer; begin { //WriteLn('RemoveStayOnTopFlags ', InRemoveStayOnTopFlags); if InRemoveStayOnTopFlags = 0 then begin New(StayOnTopWindowsInfo); StayOnTopWindowsInfo^.AppHandle := AppHandle; StayOnTopWindowsInfo^.SystemTopAlso := ASystemTopAlso; StayOnTopWindowsInfo^.StayOnTopList := TList.Create; WindowInfo := GetWindowInfo(AppHandle); WindowInfo^.StayOnTopList := StayOnTopWindowsInfo^.StayOnTopList; EnumThreadWindows(GetWindowThreadProcessId(AppHandle, nil), @EnumStayOnTopRemove, LPARAM(StayOnTopWindowsInfo)); for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do SetWindowPos(HWND(WindowInfo^.StayOnTopList[I]), HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME); Dispose(StayOnTopWindowsInfo); end; inc(InRemoveStayOnTopFlags);} end; procedure RestoreStayOnTopFlags(AppHandle: HWND); var WindowInfo: TWindowInfo; I: integer; begin { //WriteLn('RestoreStayOnTopFlags ', InRemoveStayOnTopFlags); if InRemoveStayOnTopFlags = 1 then begin WindowInfo := GetWindowInfo(AppHandle); if WindowInfo^.StayOnTopList <> nil then begin for I := 0 to WindowInfo^.StayOnTopList.Count - 1 do SetWindowPos(HWND(WindowInfo^.StayOnTopList.Items[I]), HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_DRAWFRAME); FreeAndNil(WindowInfo^.StayOnTopList); end; end; if InRemoveStayOnTopFlags > 0 then dec(InRemoveStayOnTopFlags);} end; function WndClassName(Wnd: HWND): String; inline; var winClassName: array[0..19] of widechar; begin GetClassName(Wnd, @winClassName, 20); Result := winClassName; end; function IsAlienWindow(Wnd: HWND): Boolean; const // list window class names is taken here: // http://www.pocketpcdn.com/print/articles/?&atb.set(c_id)=51&atb.set(a_id)=7165&atb.perform(details)= AlienWindowClasses: array[0..7] of String = ( 'menu_worker', // can be also found by SHFindMenuBar 'MS_SOFTKEY_CE_1.0', // google about that one. as I understand it related to bottom menu too 'Default Ime', 'Ime', 'static', 'OLEAUT32', 'FAKEIMEUI', 'tooltips_class32' ); var i: integer; WndName: String; begin WndName := WndClassName(Wnd); Result := False; for i := Low(AlienWindowClasses) to High(AlienWindowClasses) do if WndName = AlienWindowClasses[i] then Exit(True); end; {procedure LogWindow(Window: HWND); begin DbgAppendToFile(ExtractFilePath(ParamStr(0)) + '1.log', 'Window = ' + IntToStr(Window) + ' ClassName = ' + WndClassName(Window) + ' Thread id = ' + IntToStr(GetWindowThreadProcessId(Window, nil))); end;} function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean; var textSize: Windows.SIZE; winHandle: HWND; canvasHandle: HDC; oldFontHandle: HFONT; begin winHandle := AWinControl.Handle; canvasHandle := GetDC(winHandle); oldFontHandle := SelectObject(canvasHandle, Windows.SendMessage(winHandle, WM_GetFont, 0, 0)); DeleteAmpersands(Text); Result := LCLIntf.GetTextExtentPoint32(canvasHandle, PChar(Text), Length(Text), textSize); if Result then begin Width := textSize.cx; Height := textSize.cy; end; SelectObject(canvasHandle, oldFontHandle); ReleaseDC(winHandle, canvasHandle); end; function GetControlText(AHandle: HWND): string; var TextLen: dword; tmpWideStr: WideString; begin TextLen := GetWindowTextLength(AHandle); SetLength(tmpWideStr, TextLen+1); GetWindowTextW(AHandle, PWideChar(tmpWideStr), TextLen + 1); Result := UTF8Encode(tmpWideStr); end; procedure WideStrCopy(Dest, Src: PWideChar); var counter : longint; Begin counter := 0; while Src[counter] <> #0 do begin Dest[counter] := Src[counter]; Inc(counter); end; Dest[counter] := #0; end; { Exactly equal to StrLCopy but for PWideChars Copyes a widestring up to a maximal length, in WideChars } function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar; var counter: SizeInt; begin counter := 0; while (Source[counter] <> #0) and (counter < MaxLen) do begin Dest[counter] := Source[counter]; Inc(counter); end; { terminate the string } Dest[counter] := #0; Result := Dest; end; function WideStrCmp(W1, W2: PWideChar): Integer; var counter: Integer; Begin counter := 0; While W1[counter] = W2[counter] do Begin if (W2[counter] = #0) or (W1[counter] = #0) then break; Inc(counter); end; Result := ord(W1[counter]) - ord(W2[counter]); end; function GetWinCEPlatform: TApplicationType; {$ifdef MSWindows} begin Result := atDesktop; end; {$else} var buf: array[0..50] of WideChar; begin Result := atDefault; if Windows.SystemParametersInfo(SPI_GETPLATFORMTYPE, sizeof(buf), @buf, 0) then begin if WideStrCmp(@buf, 'PocketPC') = 0 then Result := atPDA else if WideStrCmp(@buf, 'SmartPhone') = 0 then Result := atKeyPadDevice else // Other devices can set anything for the platform name, // see http://bugs.freepascal.org/view.php?id=16615 // Here we just suppose that they are atDesktop Result := atDesktop; end else if GetLastError = ERROR_ACCESS_DENIED then Result := atKeyPadDevice else Result := atPDA; end; {$endif} function IsHiResMode: Boolean; begin {$ifdef MSWindows} Result := False; {$else} Result := Screen.Width > 240; {$endif} end; {------------------------------------------------------------------------------- procedure AddToChangedMenus(Window: HWnd); Adds Window to the list of windows which need to redraw the main menu. -------------------------------------------------------------------------------} procedure AddToChangedMenus(Window: HWnd); begin if ChangedMenus.IndexOf(Pointer(Window)) = -1 then // Window handle is not yet in the list ChangedMenus.Add(Pointer(Window)); end; {------------------------------------------------------------------------------ Method: RedrawMenus Params: None Returns: Nothing Redraws all changed menus ------------------------------------------------------------------------------} procedure RedrawMenus; var I: integer; begin for I := 0 to ChangedMenus.Count - 1 do DrawMenuBar(HWND(ChangedMenus[I])); ChangedMenus.Clear; end; procedure UpdateWindowsVersion; {$ifdef WinCE} var versionInfo: OSVERSIONINFO; begin WindowsVersion := wince_other; System.FillChar(versionInfo, sizeof(OSVERSIONINFO), #0); versionInfo.dwOSVersionInfoSize := sizeof(OSVERSIONINFO); if GetVersionEx(@versionInfo) then begin case versionInfo.dwMajorVersion of 1: WindowsVersion := wince_1; 2: WindowsVersion := Wince_2; 3: WindowsVersion := Wince_3; 4: WindowsVersion := Wince_4; 5: begin if versionInfo.dwMinorVersion = 2 then WindowsVersion := Wince_6 else WindowsVersion := Wince_5; end; 6: WindowsVersion := Wince_6; end; end; end; {$else} begin case Win32MajorVersion of 0..3:; 4: begin if Win32Platform = VER_PLATFORM_WIN32_NT then WindowsVersion := wvNT4 else case Win32MinorVersion of 10: WindowsVersion := wv98; 90: WindowsVersion := wvME; else WindowsVersion :=wv95; end; end; 5: begin case Win32MinorVersion of 0: WindowsVersion := wv2000; 1: WindowsVersion := wvXP; else // XP64 has also a 5.2 version // we could detect that based on arch and versioninfo.Producttype WindowsVersion := wvServer2003; end; end; 6: begin case Win32MinorVersion of 0: WindowsVersion := wvVista; 1: WindowsVersion := wv7; else WindowsVersion := wvLater; end; end; else WindowsVersion := wvLater; end; end; {$endif} initialization DefaultWindowInfo := TWindowInfo.Create; WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo'); ChangedMenus := TList.Create; UpdateWindowsVersion(); finalization Windows.GlobalDeleteAtom(WindowInfoAtom); WindowInfoAtom := 0; ChangedMenus.Free; end.