mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-29 02:23:42 +02:00
1803 lines
57 KiB
ObjectPascal
1803 lines
57 KiB
ObjectPascal
{ ------------------------------
|
|
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: 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: 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.
|