paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-21 10:42:32 +02:00
Code Issues Packages Projects Releases Wiki Activity
00d38fd701
lazarus/lcl/interfaces/win32/win32proc.pp

1740 lines
57 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
win32proc.pp - Misc Support Functions
-------------------
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL.txt, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
unit win32proc;
{$mode objfpc}{$H+}
{$I win32defines.inc}
interface
uses
Windows, Win32Extra, Classes, SysUtils,
LMessages, LCLType, LCLProc, LCLMessageGlue,Controls, Forms, Menus, GraphType, IntfGraphics;
const
LV_DISP_INFO_COUNT = 2;
Type
TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown);
TParentMsgHandlerProc = function(const AWinControl: TWinControl; Window: HWnd;
Msg: UInt; WParam: Windows.WParam; LParam: Windows.LParam;
var MsgResult: Windows.LResult; var WinProcess: Boolean): Boolean;
PWin32WindowInfo = ^TWin32WindowInfo;
TWin32WindowInfo = record
Overlay: HWND; // overlay, transparent window on top, used by designer
UpDown: HWND;
PopupMenu: TPopupMenu;
DefWndProc: WNDPROC;
ParentMsgHandler: TParentMsgHandlerProc;
WinControl: TWinControl;
PWinControl: TWinControl; // control to paint for
AWinControl: TWinControl; // control associated with (for buddy controls)
List: TStrings;
StayOnTopList: TList; // a list of windows that were normalized when showing modal
needParentPaint: boolean; // has a tabpage as parent, and is winxp themed
isTabPage: boolean; // is window of tabpage
isComboEdit: boolean; // is buddy of combobox, the edit control
isChildEdit: boolean; // is buddy edit of a control
ThemedCustomDraw: boolean;// controls needs themed drawing in wm_notify/nm_customdraw
MaxLength: integer;
DrawItemIndex: integer; // in case of listbox, when handling WM_DRAWITEM
DrawItemSelected: boolean;// whether this item is selected LB_GETSEL not uptodate yet
MouseX, MouseY: smallint; // noticing spurious WM_MOUSEMOVE messages
DispInfoTextA: array [0..LV_DISP_INFO_COUNT-1] of AnsiString; // buffer for ListView LVN_GETDISPINFO notification
DispInfoTextW: array [0..LV_DISP_INFO_COUNT-1] of WideString; // it's recommended to keep buffer unchanged
DispInfoIndex: Integer; // between 2 calls of LVN_GETDISPINFO
IMEComposed: Boolean;
case integer of
0: (spinValue: Double);
1: (
TrackValid: Boolean; // Set when we have a valid trackpos
TrackPos: Integer // keeps the thumb position while tracking
);
end;
function WM_To_String(WM_Message: Integer): string;
function WindowPosFlagsToString(Flags: UINT): string;
procedure EventTrace(Message: String; Data: TObject);
procedure AssertEx(Const Message: String; Const PassErr: Boolean;
Const Severity: Byte);
procedure AssertEx(Const PassErr: Boolean; Const Message: String);
procedure AssertEx(Const Message: String);
function GetShiftState: TShiftState;
procedure CallEvent(Const Target: TObject; Event: TNotifyEvent;
Const Data: Pointer; Const EventType: TEventType);
function ObjectToHWND(Const AObject: TObject): HWND;
function LCLControlSizeNeedsUpdate(Sender: TWinControl;
SendSizeMsgOnDiff: boolean): boolean;
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
procedure LCLBoundsToWin32Bounds(Sender: TObject;
var Left, Top, Width, Height: Integer);
procedure Win32PosToLCLPos(Sender: TObject; var Left, Top: SmallInt);
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
function BorderStyleToWin32Flags(Style: TFormBorderStyle): DWORD;
function BorderStyleToWin32FlagsEx(Style: TFormBorderStyle): DWORD;
function GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
function AllocWindowInfo(Window: HWND): PWin32WindowInfo;
function DisposeWindowInfo(Window: HWND): boolean;
function GetWin32WindowInfo(Window: HWND): PWin32WindowInfo;
procedure RemoveStayOnTopFlags(Window: HWND; ASystemTopAlso: Boolean = False);
procedure RestoreStayOnTopFlags(Window: HWND);
procedure AddToChangedMenus(Window: HWnd);
procedure RedrawMenus;
function MeasureTextForWnd(const AWindow: HWND; Text: string; var Width, Height: integer): boolean;
function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
function GetControlText(AHandle: HWND): string;
procedure FillRawImageDescriptionColors(var ADesc: TRawImageDescription);
procedure FillRawImageDescription(const ABitmapInfo: Windows.TBitmap; out ADesc: TRawImageDescription);
function GetBitmapOrder(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP):TRawImageLineOrder;
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;
procedure BlendRect(ADC: HDC; const ARect: TRect; Color: ColorRef);
function GetLastErrorText(AErrorCode: Cardinal): String;
function BitmapToRegion(hBmp: HBITMAP; cTransparentColor: COLORREF = 0; cTolerance: COLORREF = $101010): HRGN;
function WndClassName(Wnd: HWND): String; inline;
function WndText(Wnd: HWND): String; inline;
{ String functions that may be moved to the RTL in the future }
function WideStrLCopy(dest, source: PWideChar; maxlen: SizeInt): PWideChar;
procedure UpdateWindowsVersion;
type
PStayOnTopWindowsInfo = ^TStayOnTopWindowsInfo;
TStayOnTopWindowsInfo = record
AppWindow: HWND;
SystemTopAlso: Boolean;
StayOnTopList: TList;
end;
TWindowsVersion = (
wvUnknown,
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,
wvLater
);
var
DefaultWindowInfo: TWin32WindowInfo;
WindowInfoAtom: ATOM;
ChangedMenus: TList; // list of HWNDs which menus needs to be redrawn
UnicodeEnabledOS: Boolean = False;
WindowsVersion: TWindowsVersion = wvUnknown;
implementation
uses
LCLStrConsts, Dialogs, StdCtrls, ExtCtrls,
LCLIntf; //remove this unit when GetWindowSize is moved to TWSWinControl
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$ENDIF}
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';
$0088: Result := 'WM_SYNCPAINT';
$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';
// edit control messages start (todo: add more if needed)
$00B0: Result := 'EM_GETSEL';
$00B1: Result := 'EM_SETSEL';
$00B7: Result := 'EM_SCROLLCARET';
$00C5: Result := 'EM_LIMITTEXT';
$00CC: Result := 'EM_SETPASSWORDCHAR';
$00CF: Result := 'EM_SETREADONLY';
// edit control messages end
// scrollbar control messages start
$00E0: Result := 'SBM_SETPOS';
$00E1: Result := 'SBM_GETPOS';
$00E2: Result := 'SBM_SETRANGE';
$00E3: Result := 'SBM_GETRANGE';
$00E4: Result := 'SBM_ENABLE_ARROWS';
$00E6: Result := 'SBM_SETRANGEREDRAW';
$00E9: Result := 'SBM_SETSCROLLINFO';
$00EA: Result := 'SBM_GETSCROLLINFO';
$00EB: Result := 'SBM_GETSCROLLBARINFO';
// scrollbar control messages end
// button control messages start
$00F0: Result := 'BM_GETCHECK';
$00F1: Result := 'BM_SETCHECK';
$00F2: Result := 'BM_GETSTATE';
$00F3: Result := 'BM_SETSTATE';
$00F4: Result := 'BM_SETSTYLE';
$00F5: Result := 'BM_CLICK';
$00F6: Result := 'BM_GETIMAGE';
$00F7: Result := 'BM_SETIMAGE';
$00F8: Result := 'BM_SETDONTCLICK';
// button control messages end
$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';
$0127: Result := 'WM_CHANGEUISTATE';
$0128: Result := 'WM_UPDATEUISTATE';
$0129: Result := 'WM_QUERYUISTATE';
$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';
$0140: Result := 'CB_GETEDITSEL';
$0141: Result := 'CB_LIMITTEXT';
$0142: Result := 'CB_SETEDITSEL';
$0143: Result := 'CB_ADDSTRING';
$0144: Result := 'CB_DELETESTRING';
$0145: Result := 'CB_DIR';
$0146: Result := 'CB_GETCOUNT';
$0147: Result := 'CB_GETCURSEL';
$0148: Result := 'CB_GETLBTEXT';
$0149: Result := 'CB_GETLBTEXTLEN';
$014A: Result := 'CB_INSERTSTRING';
$014B: Result := 'CB_RESETCONTENT';
$014C: Result := 'CB_FINDSTRING';
$014D: Result := 'CB_SELECTSTRING';
$014E: Result := 'CB_SETCURSEL';
$014F: Result := 'CB_SHOWDROPDOWN';
$0150: Result := 'CB_GETITEMDATA';
$0151: Result := 'CB_SETITEMDATA';
$0152: Result := 'CB_GETDROPPEDCONTROLRECT';
$0153: Result := 'CB_SETITEMHEIGHT';
$0154: Result := 'CB_GETITEMHEIGHT';
$0155: Result := 'CB_SETEXTENDEDUI';
$0156: Result := 'CB_GETEXTENDEDUI';
$0157: Result := 'CB_GETDROPPEDSTATE';
$0158: Result := 'CB_FINDSTRINGEXACT';
$0159: Result := 'CB_SETLOCALE';
$015A: Result := 'CB_GETLOCALE';
$015B: Result := 'CB_GETTOPINDEX';
$015C: Result := 'CB_SETTOPINDEX';
$015D: Result := 'CB_GETHORIZONTALEXTENT';
$015E: Result := 'CB_SETHORIZONTALEXTENT';
$015F: Result := 'CB_GETDROPPEDWIDTH';
$0160: Result := 'CB_SETDROPPEDWIDTH';
$0161: Result := 'CB_INITSTORAGE';
$0163: Result := 'CB_MULTIPLEADDSTRING';
$0164: Result := 'CB_GETCOMBOBOXINFO';
$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';
$02A2: Result := 'WM_NCMOUSELEAVE';
$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';
$031F: Result := 'WM_DWMNCRENDERINGCHANGED';
$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';
// progress bar
$0401: Result := 'PBM_SETRANGE';
$0402: Result := 'PBM_SETPOS';
$0403: Result := 'PBM_DELTAPOS';
$0404: Result := 'PBM_SETSTEP';
$0405: Result := 'PBM_STEPIT';
$0406: Result := 'PBM_SETRANGE32';
$0407: Result := 'PBM_GETRANGE';
$0408: Result := 'PBM_GETPOS';
$0409: Result := 'PBM_SETBARCOLOR';
$040A: Result := 'PBM_SETMARQUEE';
$040D: Result := 'PBM_GETSTEP';
$040E: Result := 'PBM_GETBKCOLOR';
$040F: Result := 'PBM_GETBARCOLOR';
$0410: Result := 'PBM_SETSTATE';
$0411: Result := 'PBM_GETSTATE';
// misc
$0469: Result := 'UDM_SETBUDDY';
$046A: Result := 'UDM_GETBUDDY';
$102C: Result := 'LVM_GETITEMSTATE';
$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: EventTrace
Params: Message - Event name
Data - Object which fired this event
Returns: Nothing
Displays a trace about an event
------------------------------------------------------------------------------}
procedure EventTrace(Message: String; Data: TObject);
begin
If Data = Nil Then
Assert(False, Format('Trace:Event [%S] fired', [Message]))
Else
Assert(False, Format('Trace:Event [%S] fired for %S',[Message, Data.Classname]));
end;
{------------------------------------------------------------------------------
function: AssertEx
Params: Message - Message sent
PassErr - Pass error to a catching procedure (default: False)
Severity - How severe is the error on a scale from 0 to 3
(default: 0)
Returns: Nothing
An expanded, better version of Assert
------------------------------------------------------------------------------}
procedure AssertEx(Const Message: String; Const PassErr: Boolean; Const Severity: Byte);
begin
Case Severity Of
0:
begin
Assert(PassErr, Message);
end;
1:
begin
Assert(PassErr, Format('Trace:%S', [Message]));
end;
2:
begin
Case IsConsole Of
True:
begin
WriteLn(rsWin32Warning, Message);
end;
False:
begin
MessageBox(0, PChar(Message), PChar(rsWin32Warning), MB_OK);
end;
end;
end;
3:
begin
Case IsConsole Of
True:
begin
WriteLn(rsWin32Error, Message);
end;
False:
begin
MessageBox(0, PChar(Message), Nil, MB_OK);
end;
end;
end;
end;
end;
procedure AssertEx(Const PassErr: Boolean; Const Message: String);
begin
AssertEx(Message, PassErr, 0);
end;
procedure AssertEx(Const Message: String);
begin
AssertEx(Message, False, 0);
end;
{------------------------------------------------------------------------------
function: GetShiftState
Params: None
Returns: A shift state
Creates a TShiftState set based on the status when the function was called.
------------------------------------------------------------------------------}
function GetShiftState: TShiftState;
begin
Result := [];
// NOTE: it may be better to use GetAsyncKeyState
// if GetKeyState AND $8000 <> 0 then down (e.g. shift)
// if GetKeyState AND 1 <> 0, then toggled on (e.g. num lock)
If (GetKeyState(VK_SHIFT) and $8000) <> 0 then
Result := Result + [ssShift];
If (GetKeyState(VK_CAPITAL) and 1) <> 0 then
Result := Result + [ssCaps];
If (GetKeyState(VK_CONTROL) and $8000) <> 0 then
Result := Result + [ssCtrl];
If (GetKeyState(VK_MENU) and $8000) <> 0 then
Result := Result + [ssAlt];
If (GetKeyState(VK_NUMLOCK) and 1) <> 0 then
Result := Result + [ssNum];
//TODO: ssSuper
If (GetKeyState(VK_SCROLL) and 1) <> 0 then
Result := Result + [ssScroll];
// GetKeyState takes mouse button swap into account (GetAsyncKeyState doesn't),
// so no need to test GetSystemMetrics(SM_SWAPBUTTON)
If (GetKeyState(VK_LBUTTON) and $8000) <> 0 then
Result := Result + [ssLeft];
If (GetKeyState(VK_MBUTTON) and $8000) <> 0 then
Result := Result + [ssMiddle];
If (GetKeyState(VK_RBUTTON) and $8000) <> 0 then
Result := Result + [ssRight];
//TODO: ssAltGr
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
Assert(False, '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;
}
{-----------------------------------------------------------------------------
procedure: CallEvent
Params: Target - the object for which the event will be called
Event - event to call
Data - misc data
EventType - the type of event
Returns: Nothing
Calls an event
-------------------------------------------------------------------------------}
procedure CallEvent(Const Target: TObject; Event: TNotifyEvent; Const Data: Pointer; Const EventType: TEventType);
begin
If Assigned(Target) And Assigned(Event) Then
begin
Case EventType Of
etNotify:
begin
Event(Target);
end;
end;
end;
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
Assert(False, 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;
(***********************************************************************
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
LMessage: TLMSize;
IntfWidth, IntfHeight: integer;
begin
Result := False;
LCLIntf.GetWindowSize(Sender.Handle, 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.
It is used in GetClientBounds to define LCL bounds from win32 bounds.
-------------------------------------------------------------------------------}
function GetLCLClientBoundsOffset(Sender: TObject; var ORect: TRect): boolean;
var
TM: TextMetricA;
DC: HDC;
Handle: HWND;
TheWinControl: TWinControl;
ARect: TRect;
begin
Result := False;
if (Sender = nil) or (not (Sender is TWinControl)) then exit;
TheWinControl := TWinControl(Sender);
if not TheWinControl.HandleAllocated then exit;
Handle := TheWinControl.Handle;
FillChar(ORect, SizeOf(ORect), 0);
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;
if (TheWinControl is TCustomGroupBox) then
begin
// The client area of a groupbox under winapi is the whole size, including
// the frame. The LCL defines the client area without the frame.
// -> Adjust the position
// add the upper frame with the caption
DC := Windows.GetDC(Handle);
GetTextMetrics(DC, TM);
ORect.Top := TM.TMHeight;
Windows.ReleaseDC(Handle, DC);
// add the left, right and bottom frame borders
ORect.Left := 2;
ORect.Right := -2;
ORect.Bottom := -2;
end else
if TheWinControl is TCustomNoteBook then
begin
// Can't use complete client rect in win32 interface, top part contains the tabs
Windows.GetClientRect(Handle, @ARect);
ORect := ARect;
Windows.SendMessage(Handle, TCM_AdjustRect, 0, LPARAM(@ORect));
Dec(ORect.Right, ARect.Right);
Dec(ORect.Bottom, ARect.Bottom);
end;
{
if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_CLIENTEDGE) <> 0 then
begin
Dec(LeftOffset, Windows.GetSystemMetrics(SM_CXEDGE));
Dec(TopOffset, Windows.GetSystemMetrics(SM_CYEDGE));
end;
}
Result := True;
end;
function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
var
OwnerObject: TObject;
begin
OwnerObject := GetWin32WindowInfo(Handle)^.WinControl;
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 Win32PosToLCLPos(Sender: TObject; var Left, Top: SmallInt);
var
ORect: TRect;
begin
if (Sender=nil) or (not (Sender is TWinControl)) then exit;
if not GetLCLClientBoundsOffset(TWinControl(Sender).Parent, ORect) then exit;
dec(Left, ORect.Left);
dec(Top, ORect.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;
{
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 := GetWindowLong(Handle, GWL_STYLE);
NewStyle := (Style and StyleMask) or (CurrentStyle and (not StyleMask));
SetWindowLong(Handle, GWL_STYLE, NewStyle);
end;
function BorderStyleToWin32Flags(Style: TFormBorderStyle): DWORD;
begin
Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
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;
function BorderStyleToWin32FlagsEx(Style: TFormBorderStyle): DWORD;
begin
Result := 0;
case Style of
bsDialog:
Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
bsToolWindow, bsSizeToolWin:
Result := WS_EX_TOOLWINDOW;
end;
end;
function GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
{$NOTE Belongs in Win32WSForms, but is needed in windowproc}
begin
if csDesigning in AForm.ComponentState then
Result := bsSizeable
else
Result := AForm.BorderStyle;
end;
function AllocWindowInfo(Window: HWND): PWin32WindowInfo;
var
WindowInfo: PWin32WindowInfo;
begin
New(WindowInfo);
FillChar(WindowInfo^, sizeof(WindowInfo^), 0);
WindowInfo^.DrawItemIndex := -1;
Windows.SetProp(Window, PChar(PtrUInt(WindowInfoAtom)), PtrUInt(WindowInfo));
Result := WindowInfo;
end;
function DisposeWindowInfo(Window: HWND): boolean;
var
WindowInfo: PWin32WindowInfo;
begin
WindowInfo := PWin32WindowInfo(Windows.GetProp(Window, PChar(PtrUInt(WindowInfoAtom))));
Result := Windows.RemoveProp(Window, PChar(PtrUInt(WindowInfoAtom)))<>0;
if Result then
begin
WindowInfo^.StayOnTopList.Free;
Dispose(WindowInfo);
end;
end;
function GetWin32WindowInfo(Window: HWND): PWin32WindowInfo;
begin
Result := PWin32WindowInfo(Windows.GetProp(Window, PChar(PtrUInt(WindowInfoAtom))));
if Result = nil then
Result := @DefaultWindowInfo;
end;
function EnumStayOnTopRemove(Handle: HWND; Param: LPARAM): WINBOOL; stdcall;
var
AStyle: DWord;
StayOnTopWindowsInfo: PStayOnTopWindowsInfo absolute Param;
lWindowInfo: PWin32WindowInfo;
lWinControl: TWinControl;
begin
Result := True;
AStyle := GetWindowLong(Handle, GWL_EXSTYLE);
if (AStyle and WS_EX_TOPMOST) <> 0 then // if stay on top then
begin
// Don't remove system-wide stay on top, unless desired
if not StayOnTopWindowsInfo^.SystemTopAlso then
begin
lWindowInfo := GetWin32WindowInfo(Handle);
if (lWindowInfo <> nil) then
begin
lWinControl := lWindowInfo^.WinControl;
if (lWinControl <> nil) and (lWinControl is TCustomForm)
and (TCustomForm(lWinControl).FormStyle = fsSystemStayOnTop) then
Exit;
end;
end;
StayOnTopWindowsInfo^.StayOnTopList.Add(Pointer(Handle));
SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOSENDCHANGING);
end;
end;
procedure RemoveStayOnTopFlags(Window: HWND; ASystemTopAlso: Boolean = False);
var
StayOnTopWindowsInfo: PStayOnTopWindowsInfo;
WindowInfo: PWin32WindowInfo;
begin
// WriteLn('RemoveStayOnTopFlags 1');
if InRemoveStayOnTopFlags = 0 then
begin
New(StayOnTopWindowsInfo);
StayOnTopWindowsInfo^.AppWindow := Window;
StayOnTopWindowsInfo^.SystemTopAlso := ASystemTopAlso;
StayOnTopWindowsInfo^.StayOnTopList := TList.Create;
WindowInfo := GetWin32WindowInfo(Window);
WindowInfo^.StayOnTopList := StayOnTopWindowsInfo^.StayOnTopList;
EnumThreadWindows(GetWindowThreadProcessId(Window, nil),
@EnumStayOnTopRemove, LPARAM(StayOnTopWindowsInfo));
Dispose(StayOnTopWindowsInfo);
end;
inc(InRemoveStayOnTopFlags);
// WriteLn('RemoveStayOnTopFlags 2');
end;
procedure RestoreStayOnTopFlags(Window: HWND);
var
WindowInfo: PWin32WindowInfo;
I: integer;
begin
// WriteLn('RestoreStayOnTopFlags 1');
if InRemoveStayOnTopFlags = 1 then
begin
WindowInfo := GetWin32WindowInfo(Window);
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_NOSENDCHANGING);
FreeAndNil(WindowInfo^.StayOnTopList);
end;
end;
if InRemoveStayOnTopFlags > 0 then
dec(InRemoveStayOnTopFlags);
// WriteLn('RestoreStayOnTopFlags 2');
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;
function MeasureTextForWnd(const AWindow: HWND; Text: string; var Width,
Height: integer): boolean;
var
textSize: Windows.SIZE;
canvasHandle: HDC;
oldFontHandle, newFontHandle: HFONT;
begin
canvasHandle := Windows.GetDC(AWindow);
newFontHandle := HFONT(SendMessage(AWindow, WM_GETFONT, 0, 0));
oldFontHandle := SelectObject(canvasHandle, newFontHandle);
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);
Windows.ReleaseDC(AWindow, canvasHandle);
end;
function MeasureText(const AWinControl: TWinControl; Text: string; var Width, Height: integer): boolean;
begin
Result := MeasureTextForWnd(AWinControl.Handle, Text, Width, Height);
end;
function GetControlText(AHandle: HWND): string;
var
TextLen: dword;
{$ifdef WindowsUnicodeSupport}
AnsiBuffer: string;
WideBuffer: WideString;
{$endif}
begin
{$ifdef WindowsUnicodeSupport}
if UnicodeEnabledOS then
begin
TextLen := Windows.GetWindowTextLengthW(AHandle);
SetLength(WideBuffer, TextLen);
If TextLen > 0 // Never give Windows the chance to write to System.emptychar
Then TextLen := Windows.GetWindowTextW(AHandle, PWideChar(WideBuffer), TextLen + 1);
SetLength(WideBuffer, TextLen);
Result := UTF16ToUTF8(WideBuffer);
end
else
begin
TextLen := Windows.GetWindowTextLength(AHandle);
SetLength(AnsiBuffer, TextLen);
If TextLen > 0 // Never give Windows the chance to write to System.emptychar
Then TextLen := Windows.GetWindowText(AHandle, PChar(AnsiBuffer), TextLen + 1);
SetLength(AnsiBuffer, TextLen);
Result := AnsiToUtf8(AnsiBuffer);
end;
{$else}
TextLen := GetWindowTextLength(AHandle);
SetLength(Result, TextLen);
GetWindowText(AHandle, PChar(Result), TextLen + 1);
{$endif}
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-5-5 mode
ADesc.RedPrec := 5;
ADesc.GreenPrec := 5;
ADesc.BluePrec := 5;
ADesc.RedShift := 10;
ADesc.GreenShift := 5;
ADesc.BlueShift := 0;
ADesc.Depth := 15;
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.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 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 ???
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;
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;
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;
procedure BlendRect(ADC: HDC; const ARect: TRect; Color: ColorRef);
var
bmp, oldBmp: HBitmap;
MemDC: HDC;
Blend: TBlendFunction;
Pixel: TRGBAQuad;
Brush: HBrush;
begin
if IsRectEmpty(ARect) then Exit;
Pixel.Blue := Color shr 16;
Pixel.Green := Color shr 8;
Pixel.Red := Color;
bmp := CreateBitmap(1, 1, 1, 32, @Pixel);
MemDC := CreateCompatibleDC(ADC);
OldBmp := SelectObject(MemDC, Bmp);
Blend.BlendOp := AC_SRC_OVER;
Blend.BlendFlags := 0;
Blend.SourceConstantAlpha := 128;
Blend.AlphaFormat := 0;
AlphaBlend(ADC, ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, MemDC, 0, 0, 1, 1, Blend);
SelectObject(MemDC, OldBmp);
DeleteDC(MemDC);
DeleteObject(Bmp);
Brush := CreateSolidBrush(Color);
FrameRect(ADC, ARect, Brush);
DeleteObject(Brush);
end;
function GetLastErrorText(AErrorCode: Cardinal): String;
var
r: cardinal;
tmp: PChar;
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;
(*
BitmapToRegion : Create a region from the "non-transparent" pixels of a bitma
Author : Jean-Edouard Lachand-Robert (http://www.geocities.com/Paris/LeftBank/1160/resume.htm), June 1998
hBmp : Source bitmap
cTransparentColor : Color base for the "transparent" pixels (default is black)
cTolerance : Color tolerance for the "transparent" pixels
A pixel is assumed to be transparent if the value of each of its 3 components (blue, green and red) is
greater or equal to the corresponding value in cTransparentColor and is lower or equal to the
corresponding value in cTransparentColor + cTolerance
*)
function BitmapToRegion(hBmp: HBITMAP; cTransparentColor: COLORREF = 0; cTolerance: COLORREF = $101010): HRGN;
const
ALLOC_UNIT = 100;
var
AWidth, AHeight: Integer;
maxRects: DWORD;
hData: THANDLE;
pData: PRGNDATA;
lr, lg, lb, hr, hg, hb: Byte;
x, y, x0: Integer;
pr: PRect;
h: HRGN;
WinBmp: Windows.TBitmap;
P, Data: PRGBAQuad;
RS: PtrUInt;
ARawImage, DstRawImage: TRawImage;
SourceImage, DestImage: TLazIntfImage;
procedure FillDescription(out ADesc: TRawImageDescription);
begin
ADesc.Init;
ADesc.Format := ricfRGBA;
ADesc.PaletteColorCount := 0;
ADesc.MaskBitsPerPixel := 0;
ADesc.Depth := 32;
ADesc.Width := AWidth;
ADesc.Height := AHeight;
ADesc.BitOrder := riboBitsInOrder;
ADesc.ByteOrder := riboMSBFirst;
ADesc.LineOrder := riloTopToBottom;
ADesc.BitsPerPixel := 32;
ADesc.LineEnd := rileDWordBoundary;
ADesc.RedPrec := 8; // red precision. bits for red
ADesc.RedShift := 8;
ADesc.GreenPrec := 8;
ADesc.GreenShift := 16;
ADesc.BluePrec := 8;
ADesc.BlueShift := 24;
ADesc.AlphaPrec := 8;
ADesc.AlphaShift := 0;
end;
begin
Result := 0;
if Windows.GetObject(hBmp, sizeof(WinBmp), @WinBmp) = 0 then
Exit;
if not RawImage_FromBitmap(ARawImage, hBmp, 0) then
Exit;
AWidth := ARawImage.Description.Width;
AHeight := ARawImage.Description.Height;
SourceImage := TLazIntfImage.Create(ARawImage, True);
DstRawImage.Init;
FillDescription(DstRawImage.Description);
DstRawImage.DataSize := AWidth * AHeight * SizeOf(TRGBAQuad);
Data := AllocMem(DstRawImage.DataSize);
DstRawImage.Data := PByte(Data);
DestImage := TLazIntfImage.Create(DstRawImage, False);
DestImage.CopyPixels(SourceImage);
SourceImage.Free;
DestImage.Free;
RS := GetBytesPerLine(AWidth, 32, rileDWordBoundary);
// For better performances, we will use the ExtCreateRegion() function to create the
// region. This function take a RGNDATA structure on entry. We will add rectangles by
// amount of ALLOC_UNIT number in this structure
maxRects := ALLOC_UNIT;
hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects));
pData := GlobalLock(hData);
pData^.rdh.dwSize := sizeof(RGNDATAHEADER);
pData^.rdh.iType := RDH_RECTANGLES;
pData^.rdh.nCount := 0;
pData^.rdh.nRgnSize := 0;
Windows.SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
// Keep on hand highest and lowest values for the "transparent" pixel
lr := GetRValue(cTransparentColor);
lg := GetGValue(cTransparentColor);
lb := GetBValue(cTransparentColor);
hr := min($ff, lr + GetRValue(cTolerance));
hg := min($ff, lg + GetGValue(cTolerance));
hb := min($ff, lb + GetBValue(cTolerance));
P := Data;
// Scan each bitmap row from bottom to top (the bitmap is inverted vertically)
for y := 0 to AHeight - 1 do
begin
// Scan each bitmap pixel from left to righ
x := 0;
while (x < AWidth) do
begin
// Search for a continuous range of "non transparent pixels"
x0 := x;
while (x < AWidth) do
begin
with P[x] do
if (Red >= lr) and (Red <= hr) then
begin
if (Green >= lg) and (Green <= hg) then
begin
if (Blue >= lb) and (Blue <= hb) then
break; //This pixel is "transparent"
end;
end;
inc(x);
end;
if (x > x0) then
begin
// Add the pixels (x0, y) to (x, y+1) as a new rectangle in the region
if (pData^.rdh.nCount >= maxRects) then
begin
GlobalUnlock(hData);
maxRects := maxRects + ALLOC_UNIT;
hData := GlobalReAlloc(hData, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), GMEM_MOVEABLE);
pData := GlobalLock(hData);
end;
pr := PRect(PChar(pData^.Buffer));
SetRect(pr[pData^.rdh.nCount], x0, y, x, y+1);
if (x0 < pData^.rdh.rcBound.left) then
pData^.rdh.rcBound.left := x0;
if (y < pData^.rdh.rcBound.top) then
pData^.rdh.rcBound.top := y;
if (x > pData^.rdh.rcBound.right) then
pData^.rdh.rcBound.right := x;
if (y+1 > pData^.rdh.rcBound.bottom) then
pData^.rdh.rcBound.bottom := y+1;
inc(pData^.rdh.nCount);
// On Windows98, ExtCreateRegion() may fail if the number of rectangles is to
// large (ie: > 4000). Therefore, we have to create the region by multiple steps
if (pData^.rdh.nCount = 2000) then
begin
h := Windows.ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), pData^);
if (Result <> 0) then
begin
Windows.CombineRgn(Result, Result, h, RGN_OR);
Windows.DeleteObject(h);
end
else
Result := h;
pData^.rdh.nCount := 0;
Windows.SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
end;
end;
inc(x);
end;
// Go to next row (remember, the bitmap is inverted vertically
P := PRGBAQuad(PByte(P) + RS);
end;
// Create or extend the region with the remaining rectangle
h := Windows.ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), pData^);
if (Result <> 0) then
begin
Windows.CombineRgn(Result, Result, h, RGN_OR);
Windows.DeleteObject(h);
end
else
Result := h;
FreeMem(Data);
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 WndClassName(Wnd: HWND): String; inline;
var
winClassName: array[0..19] of char;
begin
GetClassName(Wnd, @winClassName, 20);
Result := winClassName;
end;
function WndText(Wnd: HWND): String; inline;
var
winText: array[0..255] of char;
begin
GetWindowText(Wnd, @winText, 256);
Result := winText;
end;
procedure UpdateWindowsVersion;
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;
procedure DoInitialization;
begin
FillChar(DefaultWindowInfo, sizeof(DefaultWindowInfo), 0);
DefaultWindowInfo.DrawItemIndex := -1;
WindowInfoAtom := Windows.GlobalAddAtom('WindowInfo');
ChangedMenus := TList.Create;
{$ifdef WindowsUnicodeSupport}
UnicodeEnabledOS := (Win32Platform = VER_PLATFORM_WIN32_NT);
{$endif}
if WindowsVersion = wvUnknown then
UpdateWindowsVersion;
end;
{$IFDEF ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$ENDIF}
initialization
DoInitialization;
finalization
Windows.GlobalDeleteAtom(WindowInfoAtom);
WindowInfoAtom := 0;
ChangedMenus.Free;
end.
Reference in New Issue View Git Blame Copy Permalink