opensource/HeidiSQL
1
0
Fork 0
mirror of https://github.com/HeidiSQL/HeidiSQL.git synced 2025-08-06 18:24:26 +08:00
Code Issues Packages Projects Releases Wiki Activity
Files
HeidiSQL/source/vcl-styles-utils/Vcl.Styles.Utils.Menus.pas

2274 lines
68 KiB
ObjectPascal
Raw Blame History

// **************************************************************************************************
//
// Unit Vcl.Styles.Utils.Menus
// unit for the VCL Styles Utils
// https://github.com/RRUZ/vcl-styles-utils/
//
// The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License");
// you may not use this file except in compliance with the License. You may obtain a copy of the
// License at http://www.mozilla.org/MPL/
//
// Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
// ANY KIND, either express or implied. See the License for the specific language governing rights
// and limitations under the License.
//
//
// Portions created by Mahdi Safsafi [SMP3] e-mail SMP@LIVE.FR
// Portions created by Rodrigo Ruz V. are Copyright (C) 2013-2023 Rodrigo Ruz V.
// All Rights Reserved.
//
// **************************************************************************************************
// Contributors :
//
// gandf https://github.com/gandf
//
// **************************************************************************************************
unit Vcl.Styles.Utils.Menus;
interface
{$DEFINE UseVCLStyleUtilsMenu}
// {$IF CompilerVersion >= 27} // uncomment these lines if you want to use the VCL Styles Menus Hooks
// {$UNDEF UseVCLStyleUtilsMenu} // included on XE6-XE8 (Embarcadero Version)
// {$IFEND} //
uses
System.Classes,
System.Types,
System.SysUtils,
System.Math,
Winapi.Windows,
Winapi.Messages,
Winapi.UxTheme,
Vcl.Themes,
Vcl.Graphics,
Vcl.ImgList,
Vcl.GraphUtil,
Vcl.Controls,
Vcl.Menus,
Vcl.Styles.Utils.SysStyleHook;
const
{ The Undocumented Messages }
MN_SETHMENU = $01E0;
MN_GETHMENU = $01E1;
MN_SIZEWINDOW = $01E2;
MN_OPENHIERARCHY = $01E3;
MN_CLOSEHIERARCHY = $01E4;
MN_SELECTITEM = $01E5;
MN_CANCELMENUS = $01E6;
MN_SELECTFIRSTVALIDITEM = $01E7;
MN_GETPPOPUPMENU = $01EA;
MN_FINDMENUWINDOWFROMPOINT = $01EB;
MN_SHOWPOPUPWINDOW = $01EC;
MN_BUTTONDOWN = $01ED;
MN_MOUSEMOVE = $01EE;
MN_BUTTONUP = $01EF;
MN_SETTIMERTOOPENHIERARCHY = $01F0;
MN_DBLCLK = $001F1;
MN_BUTTONDOWN_UP = $FFFFFFFC;
MN_BUTTONDOWN_DOWN = $FFFFFFFD;
WM_UAHDESTROYWINDOW = $0090;
WM_UAHDRAWMENU = $0091;
WM_UAHDRAWMENUITEM = $0092;
WM_UAHINITMENU = $0093;
WM_UAHMEASUREMENUITEM = $0094;
WM_UAHNCPAINTMENUPOPUP = $0095;
{ MARLETT Font Char Const }
MARLETT_RESTORE_CHAR = Char(50);
MARLETT_MINIMIZE_CHAR = Char(48);
MARLETT_CLOSE_CHAR = Char(114);
MARLETT_MAXIMIZE_CHAR = Char(49);
MARLETT_LEFT_ARROW_SCROLL_CHAR = Char(51);
MARLETT_RIGHT_ARROW_SCROLL_CHAR = Char(52);
MARLETT_UP_ARROW_SCROLL_CHAR = Char(53);
MARLETT_DOWN_ARROW_SCROLL_CHAR = Char(54);
MARLETT_PAGE_DOWN_ARROW_CHAR = Char(55);
MARLETT_RIGHT_ARROW_SUBMENU_CHAR = Char(56);
MARLETT_UP_ARROW_CHAR = Char(116);
MARLETT_DOWN_ARROW_CHAR = Char(117);
type
TSysPopupStyleHook = class;
TSysPopupItemState = set of (isHot, isDisabled, isChecked, isDefault);
TSysPopupItemStyle = (isNormal, isSep, isDropDown);
TSysPopupStyleHook = class(TSysStyleHook)
private type
{$REGION 'TSysPopupItem'}
TSysPopupItem = class
private
FIndex: integer;
FMenu: HMENU;
FHandle: HWND;
FSysParent: TSysControl;
FSysPopupStyleHook: TSysPopupStyleHook;
function GetItemRect: TRect;
function IsItemDisabled: Boolean;
function IsItemContainsSubMenu: Boolean;
function IsItemSeparator: Boolean;
function IsItemChecked: Boolean;
function IsItemDefault: Boolean;
function GetItemText: String;
function GetVCLMenuItems: TMenuItem;
function GetVCLMenuItemsFast: TMenuItem;
function GetItemBitmap: HBITMAP;
function IsItemRadioCheck: Boolean;
// function isItemVisible: Boolean;
function IsItemOwnerDraw: Boolean;
function GetItemID: WORD;
function GetVCLRealItem: TMenuItem;
public
constructor Create(SysPopupStyleHook: TSysPopupStyleHook; SysParent: TSysControl; const Index: integer; const Menu: HMENU); virtual;
Destructor Destroy; override;
property ID: WORD read GetItemID;
property ItemRect: TRect read GetItemRect;
property Disabled: Boolean read IsItemDisabled;
property Separator: Boolean read IsItemSeparator;
property HasSubMenu: Boolean read IsItemContainsSubMenu;
property Checked: Boolean read IsItemChecked;
// property Visible: Boolean read isItemVisible;
property RadioCheck: Boolean read IsItemRadioCheck;
property DefaultItem: Boolean read IsItemDefault;
property Text: String read GetItemText;
property OwnerDraw: Boolean read IsItemOwnerDraw;
property VCLMenuItems: TMenuItem read GetVCLMenuItemsFast;
property VCLItem: TMenuItem read GetVCLRealItem;
property Bitmap: HBITMAP read GetItemBitmap;
end;
{$ENDREGION}
var
FOffset: Integer;
FOffsetCache: Integer;
FSeparatorHeightCache: Integer;
FItemHeightCache: Integer;
FItemsPainted: Boolean;
FParentSubItemPainted: Boolean;
FPreviousHotItemIndex: integer;
FPaintFirstItemFromMenu: Boolean;
FKeyIndex: integer;
FSysPopupItem: TSysPopupItem;
FCount: integer;
FMenu: HMENU;
FVCLMenuItems: TMenuItem;
FNCRect: TRect;
FEnterWithKeyboard: Boolean;
FPersistentHotKeys: Boolean;
FMenuBarHook: TObject;
function GetMenuFromHandle(AHandle: HWND): HMENU;
function GetItemsCount: integer;
procedure MNSELECTITEM(var Message: TMessage); message MN_SELECTITEM;
procedure WMPRINT(var Message: TMessage); message WM_PRINT;
function GetSysPopupItem(Index: integer): TSysPopupItem;
function GetRightToLeft: Boolean;
protected
procedure EraseItem(Canvas: TCanvas; const Index: integer; const ItemRect: TRect); virtual;
procedure DoDrawItem(Canvas: TCanvas; const Index: integer; const ForceIsNotHot: Boolean = False);
procedure DrawItem(Canvas: TCanvas; const Index: integer; const ItemRect: TRect; const ItemText: String; const State: TSysPopupItemState;
const Style: TSysPopupItemStyle); Virtual;
procedure PaintBackground(Canvas: TCanvas); override;
procedure GetNbSeparator(var PNbSeparator: Integer; const PIndex: Integer);
function GetMenuItemHeight(const Index: Integer): Integer;
function GetOffset(UseCache: Boolean): Integer;
function ItemIsVisible(const Index: Integer): Boolean;
procedure SetMaxOffset();
procedure RefreshMenu();
procedure GetItemHeight();
procedure GetSeparatorHeight();
function GetClientRectHeight(var PValue: TRect): Integer;
function GetItemClicked(var PButton: Byte; PInitPos: TPoint): Integer;
function GetMousePos(): TPoint;
procedure WndProc(var Message: TMessage); override;
procedure UpdateColors; override;
procedure SetOffset(PValue: Integer);
function GetBottom(const Index: Integer): Integer;
public
constructor Create(AHandle: THandle); override;
Destructor Destroy; override;
property Menu: HMENU read FMenu;
property Items[Index: integer]: TSysPopupItem read GetSysPopupItem;
property Count: integer read FCount;
property RightToLeft: Boolean read GetRightToLeft;
property Offset: Integer read FOffset write SetOffset;
end;
implementation
{
RANGE CHECKS OFF .
IMPLICIT_STRING_CAST_LOSS OFF .
}
{$R-,WARN IMPLICIT_STRING_CAST_LOSS OFF}
uses
Vcl.Forms,
Vcl.Styles.Utils.Misc,
Vcl.Styles.Utils.SysControls,
Vcl.Styles.Utils.Graphics;
type
TControlClass = Class(TControl);
function GetBmpInfo(hBmp: HBITMAP): Bitmap;
begin
ZeroMemory(@Result, sizeof(Bitmap));
GetObject(hBmp, sizeof(Result), @Result);
end;
function GetBitmapHeight(hBmp: HBITMAP): integer;
begin
Result := GetBmpInfo(hBmp).bmHeight;
end;
function GetBitmapWidth(hBmp: HBITMAP): integer;
begin
Result := GetBmpInfo(hBmp).bmWidth;
end;
function BmpToIcon(hBmp: HBITMAP): HICON;
var
Bmp: Bitmap;
hbmMask: HBITMAP;
DC: HDC;
piconinfo: TIconInfo;
Icon: HICON;
begin
Icon := 0;
FillChar(Bmp, sizeof(Bitmap), Char(0));
if GetObject(hBmp, sizeof(Bitmap), @Bmp) > 0 then
begin
DC := GetDC(0);
if DC <> 0 then
try
hbmMask := CreateCompatibleBitmap(DC, Bmp.bmWidth, Bmp.bmHeight);
if hbmMask <> 0 then
try
ZeroMemory(@piconinfo, sizeof(piconinfo));
piconinfo.fIcon := True;
piconinfo.hbmColor := hBmp;
piconinfo.hbmMask := hbmMask;
Icon := CreateIconIndirect(piconinfo);
finally
DeleteObject(hbmMask);
end;
finally
ReleaseDC(0, DC);
end;
end;
Result := Icon;
end;
function GetMenuItemPos(Menu: HMENU; ID: integer): integer;
var
i: integer;
pMenuItemInfo: TMenuItemInfo;
begin
Result := -1;
if Menu = 0 then
Exit;
for i := 0 to GetMenuItemCount(Menu) do
begin
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(pMenuItemInfo);
pMenuItemInfo.fMask := MIIM_ID;
if (GetMenuItemInfo(Menu, i, True, pMenuItemInfo)) then
if pMenuItemInfo.wID = Cardinal(ID) then
Exit(i);
end;
end;
function IsItemHILITE(Menu: HMENU; const ItemIndex: integer): Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_STATE;
if GetMenuItemInfo(Menu, ItemIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fState and MFS_HILITE) = MFS_HILITE;
end;
{ TSysPopupStyleHook }
constructor TSysPopupStyleHook.Create(AHandle: THandle);
begin
inherited;
{$IF CompilerVersion > 23}
StyleElements := [seFont, seClient, seBorder];
{$ELSE}
OverridePaint := True;
OverridePaintNC := True;
OverrideFont := True;
{$IFEND}
FPreviousHotItemIndex := -1;
FKeyIndex := -1;
FItemsPainted := False;
FSysPopupItem := nil;
FVCLMenuItems := nil;
Offset := 0;
FSeparatorHeightCache := 1;
FItemHeightCache := 1;
FEnterWithKeyboard := False;
FPersistentHotKeys := False;
FMenuBarHook := nil;
// Font := Screen.MenuFont;
end;
destructor TSysPopupStyleHook.Destroy;
begin
if Assigned(FSysPopupItem) then
FreeAndNil(FSysPopupItem);
inherited;
end;
procedure TSysPopupStyleHook.DoDrawItem(Canvas: TCanvas; const Index: integer; const ForceIsNotHot: Boolean = False);
var
LRect, LRect2, LItemRect: TRect;
P, P2: TPoint;
State: TSysPopupItemState;
Style: TSysPopupItemStyle;
LText: String;
SaveIndex: integer;
LSysPopupItem: TSysPopupItem;
ClientRectHeight: Integer;
begin
if (Index < 0) or (Index > Count - 1) then
Exit;
LSysPopupItem := Items[Index];
LItemRect := LSysPopupItem.ItemRect;
P2 := Point(LItemRect.Left, LItemRect.Bottom);
ScreenToClient(Handle, P2);
P2.Y := P2.Y - GetOffset(True); //add offset
GetMenuItemRect(0, FMenu, Index, LRect);
//OutputDebugString(PChar(Format('Index %d Width %d Height %d Left %d Top %d', [Index, LRect.Width, LRect.Height, LRect.Left, LRect.Top])));
ClientRectHeight := GetClientRectHeight(LRect2);
LRect2.Height := ClientRectHeight;
//prevent draw not visible items on larger menus
if not PtInRect (LRect2, P2) then
Exit;
P := Point(LItemRect.Left, LItemRect.Top);
ScreenToClient(Handle, P);
P2 := P;
P2.Y := P2.Y - GetOffset(True); //add offset
if ClientRectHeight>LRect.Height then
LRect2.Height:= ClientRectHeight - LRect.Height;
//prevent draw not visible items on larger menus
if not PtInRect (LRect2, P2) then
Exit;
LItemRect := Rect(P.X, P.Y, P.X + LItemRect.Width, P.Y + LItemRect.Height);
if LItemRect.Left < 2 then
LItemRect.Left := 2;
inc(LItemRect.Right, 4);
if LItemRect.Top < 2 then
inc(LItemRect.Top, 2);
{ Item State }
State := [];
if not ForceIsNotHot then
if index <> FPreviousHotItemIndex then
Include(State, isHot);
if LSysPopupItem.Disabled then
Include(State, isDisabled);
if LSysPopupItem.Checked then
Include(State, isChecked);
if LSysPopupItem.DefaultItem then
Include(State, isDefault);
{ Item Style }
Style := isNormal;
if LSysPopupItem.Separator then
Style := isSep;
if LSysPopupItem.HasSubMenu then
Style := isDropDown;
LText := '';
if Style <> isSep then
LText := LSysPopupItem.Text;
SaveIndex := SaveDC(Canvas.Handle);
try
EraseItem(Canvas, Index, LItemRect);
finally
RestoreDC(Canvas.Handle, SaveIndex)
end;
SaveIndex := SaveDC(Canvas.Handle);
try
DrawItem(Canvas, Index, LItemRect, LText, State, Style);
finally
RestoreDC(Canvas.Handle, SaveIndex)
end;
end;
procedure TSysPopupStyleHook.DrawItem(Canvas: TCanvas; const Index: integer; const ItemRect: TRect; const ItemText: String; const State: TSysPopupItemState;
const Style: TSysPopupItemStyle);
var
LTextRect: TRect;
DC: HDC;
LPixelsPerInch: Integer;
procedure DrawSubMenu(const ItemRect: TRect);
var
LBitmap: TBitmap;
LSubMenuDetails: TThemedElementDetails;
LSubMenuDetail: TThemedMenu;
SubMenuSize: TSize;
LSubMenuRect: TRect;
begin
LSubMenuRect := Rect(0, 0, 0, 0);
LSubMenuDetail := tmPopupSubMenuNormal;
if isDisabled in State then
LSubMenuDetail := tmPopupSubMenuDisabled;
LSubMenuDetails := StyleServices.GetElementDetails(LSubMenuDetail);
StyleServices.GetElementSize(DC, LSubMenuDetails, esActual, SubMenuSize, LPixelsPerInch);
if not RightToLeft then
LSubMenuRect := Rect(ItemRect.Right - SubMenuSize.cx, ItemRect.Top, ItemRect.Right, ItemRect.Top + SubMenuSize.cy)
else
LSubMenuRect := Rect(ItemRect.Left + 4, ItemRect.Top, ItemRect.Left + 4 + SubMenuSize.Width, ItemRect.Bottom);
LBitmap := TBitmap.Create;
try
LBitmap.SetSize(SubMenuSize.Width, SubMenuSize.Height);
LBitmap.Canvas.Brush.Color := clFuchsia;
LBitmap.Canvas.FillRect(Rect(0, 0, SubMenuSize.Width, SubMenuSize.Height));
StyleServices.DrawElement(LBitmap.Canvas.Handle, LSubMenuDetails, Rect(0, 0, SubMenuSize.Width, SubMenuSize.Height), nil, LPixelsPerInch);
if RightToLeft then
begin
RotateBitmap(LBitmap, DegToRad(180), False, clFuchsia);
inc(LSubMenuRect.Top, (LBitmap.Height div 2) - 2);
End
else
Dec(LSubMenuRect.Left, 4);
TransparentBlt(DC, LSubMenuRect.Left, LSubMenuRect.Top, SubMenuSize.Width, SubMenuSize.Height, LBitmap.Canvas.Handle, 0, 0, SubMenuSize.Width,
SubMenuSize.Height, clFuchsia);
finally
LBitmap.Free;
end;
Dec(LTextRect.Right, LSubMenuRect.Width);
end;
procedure DrawSpecialChar(DC: HDC; const Sign: Char; DestRect: TRect; const Bold: Boolean = False; const Disabled: Boolean = False);
var
LogFont: TLogFont;
pOldFont: HGDIOBJ;
AFont: HFONT;
oldColor: COLORREF;
OldMode: integer;
begin
LogFont.lfHeight := DestRect.Height;
LogFont.lfWidth := 0;
LogFont.lfEscapement := 0;
LogFont.lfOrientation := 0;
if Bold then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := 0;
LogFont.lfUnderline := 0;
LogFont.lfStrikeOut := 0;
LogFont.lfCharSet := DEFAULT_CHARSET;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
LogFont.lfFaceName := 'Marlett';
if Disabled then
oldColor := ColorToRGB(StyleServices.GetStyleFontColor(sfPopupMenuItemTextDisabled))
else
begin
oldColor := ColorToRGB(StyleServices.GetStyleFontColor(sfPopupMenuItemTextNormal));
if isHot in State then
oldColor := ColorToRGB(StyleServices.GetStyleFontColor(sfPopupMenuItemTextHot));
if isDisabled in State then
oldColor := ColorToRGB(StyleServices.GetStyleFontColor(sfPopupMenuItemTextDisabled));
end;
AFont := CreateFontIndirect(LogFont);
if AFont <> 0 then
try
oldColor := SetTextColor(DC, oldColor);
pOldFont := SelectObject(DC, AFont);
try
OldMode := SetBkMode(DC, Transparent);
Winapi.Windows.DrawText(DC, Sign, 1, DestRect, DT_LEFT or DT_SINGLELINE);
SetBkMode(DC, OldMode);
SelectObject(DC, oldColor);
finally
if pOldFont <> 0 then
SelectObject(DC, pOldFont);
end;
finally
DeleteObject(AFont);
end;
end;
var
LThemedMenu: TThemedMenu;
LDetails: TThemedElementDetails;
LTextFormat: TTextFormat;
LSize: TSize;
LMenuItem: TMenuItem;
LOwnerDrawState: TOwnerDrawState;
P, LImageWidth, ImageIndex: integer;
LImageRect, R: TRect;
hBmp: HBITMAP;
BmpHeight, BmpWidth: integer;
Icon: HICON;
DisplayCheckedGlyph: Boolean;
Sign: Char;
LSysPopupItem: TSysPopupItem;
sShortCut: String;
LBitmap: TBitmap;
LParentMenu: TMenu;
ItemRect2: TRect;
begin
if Assigned(Application.Mainform) then
LPixelsPerInch := Application.MainForm.Monitor.PixelsPerInch
else
LPixelsPerInch := screen.PixelsPerInch;
DisplayCheckedGlyph := True;
ItemRect2 := ItemRect;
ItemRect2.Top := ItemRect.Top - GetOffset(True); //add offset
ItemRect2.Height := ItemRect.Height;
LTextRect := ItemRect2;
{ Fast access . }
LSysPopupItem := Items[Index]; // Do not destroy !!
DC := Canvas.Handle;
R := ItemRect2;
LThemedMenu := tmPopupItemNormal;
if isHot in State then
LThemedMenu := tmPopupItemHot;
if isDisabled in State then
LThemedMenu := tmPopupItemDisabled;
if Style = isSep then
begin
LThemedMenu := tmPopupSeparator;
inc(R.Left, 25);
end;
LDetails := StyleServices.GetElementDetails(LThemedMenu);
if (isHot in State) and (LThemedMenu = tmPopupItemDisabled) then
begin
LDetails := StyleServices.GetElementDetails(tmPopupItemHot);
LBitmap := TBitmap.Create;
LBitmap.SetSize(R.Width, R.Height);
LBitmap.PixelFormat := pf32bit;
try
Bitmap32_SetAlphaAndColor(LBitmap, 0, 0);
StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, Rect(0, 0, R.Width, R.Height));
_Darkness32(LBitmap, 30);
BitBlt(DC, R.Left, R.Top, R.Width, R.Height, LBitmap.Canvas.Handle, 0, 0, SRCCOPY);
finally
LBitmap.Free;
end;
end
else
if (LThemedMenu <> tmPopupItemNormal) and (LThemedMenu <> tmPopupItemDisabled) then
StyleServices.DrawElement(DC, LDetails, R);
if Style = isDropDown then
DrawSubMenu(ItemRect2);
LImageWidth := 0;
LMenuItem := LSysPopupItem.VCLMenuItems;
if LMenuItem <> nil then
LMenuItem := LSysPopupItem.VCLItem;
LParentMenu := nil;
if (LMenuItem <> nil) then
LParentMenu := LMenuItem.GetParentMenu;
if (LParentMenu <> nil) and (LParentMenu.OwnerDraw) and (@LMenuItem.OnDrawItem <> nil) then
begin
LMenuItem.OnDrawItem(LMenuItem, Canvas, ItemRect2, (isHot in State));
Exit;
end;
if (LParentMenu <> nil) and (LParentMenu.OwnerDraw) and (LMenuItem <> nil) and (@LMenuItem.OnAdvancedDrawItem <> nil) then
begin
LOwnerDrawState := [];
if isHot in State then
Include(LOwnerDrawState, odSelected);
if isDisabled in State then
Include(LOwnerDrawState, odDisabled);
if isChecked in State then
Include(LOwnerDrawState, odChecked);
if isDefault in State then
Include(LOwnerDrawState, odDefault);
LMenuItem.OnAdvancedDrawItem(LMenuItem, Canvas, ItemRect2, LOwnerDrawState);
Exit;
end;
if LMenuItem <> nil then
begin
{ Draw Vcl PopupMenu Bitmap }
ImageIndex := LMenuItem.ImageIndex;
if (ImageIndex < 0) and (LMenuItem.Bitmap <> nil) then
begin
LBitmap := LMenuItem.Bitmap;
if (LBitmap.Width = 16) and (LBitmap.Height = 16) then
begin
LImageWidth := LBitmap.Width;
LImageRect := Rect(0, 0, LBitmap.Width, LBitmap.Height);
RectVCenter(LImageRect, ItemRect2);
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - LBitmap.Width - 4;
LImageRect.Right := ItemRect2.Right;
end;
Canvas.Draw(LImageRect.Left, LImageRect.Top, LBitmap)
end
else
if (LBitmap.Width > 0) and (LBitmap.Height > 0) then
begin
LImageWidth := 16;
LImageRect := Rect(0, 0, 16, 16);
RectVCenter(LImageRect, ItemRect2);
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - 16 - 4;
LImageRect.Right := ItemRect2.Right;
end;
if (LSysPopupItem.Checked) and (not LSysPopupItem.RadioCheck) then
begin
R:=LImageRect;
InflateRect(R, 2, 2);
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Color :=StyleServices.GetSystemColor(clHotLight);
Canvas.Rectangle(R);
end;
Canvas.StretchDraw(LImageRect, LBitmap);
end;
end
else
if (LMenuItem.Parent <> nil) and (LMenuItem.Parent.SubMenuImages <> nil) and (ImageIndex > -1) then
begin
LImageWidth := LMenuItem.Parent.SubMenuImages.Width;
DisplayCheckedGlyph := False;
LImageRect := Rect(0, 0, LMenuItem.Parent.SubMenuImages.Width, LMenuItem.Parent.SubMenuImages.Height);
RectVCenter(LImageRect, ItemRect2);
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - LMenuItem.Parent.SubMenuImages.Width - 4;
LImageRect.Right := ItemRect2.Right;
end;
if (LSysPopupItem.Checked) and (not LSysPopupItem.RadioCheck) then
begin
R:=LImageRect;
InflateRect(R, 2, 2);
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Color :=StyleServices.GetSystemColor(clHotLight);
Canvas.Rectangle(R);
end;
LMenuItem.Parent.SubMenuImages.Draw(Canvas, LImageRect.Left, LImageRect.Top, ImageIndex);
end
else
if (LParentMenu.Images <> nil) and (ImageIndex > -1) then
begin
LImageWidth := LParentMenu.Images.Width;
DisplayCheckedGlyph := False;
LImageRect := Rect(0, 0, LParentMenu.Images.Width, LParentMenu.Images.Height);
RectVCenter(LImageRect, ItemRect2);
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - LParentMenu.Images.Width - 4;
LImageRect.Right := ItemRect2.Right;
end;
if (LSysPopupItem.Checked) and (not LSysPopupItem.RadioCheck) then
begin
R:=LImageRect;
InflateRect(R, 2, 2);
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Color :=StyleServices.GetSystemColor(clHotLight);
Canvas.Rectangle(R);
end;
LParentMenu.Images.Draw(Canvas, LImageRect.Left, LImageRect.Top, ImageIndex, not LSysPopupItem.Disabled);
end;
end
else if LSysPopupItem.Bitmap > 0 then
begin
hBmp := LSysPopupItem.Bitmap;
if hBmp < HBMMENU_POPUP_MINIMIZE + 1 then
begin
{ Draw System PopupMenu Bitmap }
DisplayCheckedGlyph := False;
case hBmp of
HBMMENU_POPUP_RESTORE:
Sign := MARLETT_RESTORE_CHAR;
HBMMENU_POPUP_MINIMIZE, HBMMENU_MBAR_MINIMIZE_D:
Sign := MARLETT_MINIMIZE_CHAR;
HBMMENU_POPUP_MAXIMIZE:
Sign := MARLETT_MAXIMIZE_CHAR;
HBMMENU_POPUP_CLOSE, HBMMENU_MBAR_CLOSE_D:
Sign := MARLETT_CLOSE_CHAR;
else
Sign := Char(0);
end;
if Sign <> #0 then
begin
LImageRect := Rect(0, 0, 10, 10);
R := Rect(ItemRect2.Left, ItemRect2.Top, ItemRect2.Left + 30, ItemRect2.Bottom);
RectCenter(LImageRect, ItemRect2);
if not RightToLeft then
LImageRect.Left := ItemRect2.Left + 6 //Fix center image
else
begin
LImageRect.Left := ItemRect2.Right - 10 - 4;
LImageRect.Right := ItemRect2.Right;
end;
DrawSpecialChar(DC, Sign, LImageRect, False, (isDisabled in State));
end;
end
else
begin
{ Draw PopupMenu Bitmap }
BmpWidth := GetBitmapWidth(hBmp);
BmpHeight := GetBitmapHeight(hBmp);
if (BmpWidth > 0) and (BmpHeight > 0) then
begin
DisplayCheckedGlyph := False;
LImageRect := Rect(0, 0, BmpWidth, BmpHeight);
RectVCenter(LImageRect, ItemRect2);
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - BmpWidth - 4;
LImageRect.Right := ItemRect2.Right;
end;
Icon := BmpToIcon(hBmp);
if Icon <> 0 then
begin
if (LSysPopupItem.Checked) and (not LSysPopupItem.RadioCheck) then
begin
R:=LImageRect;
InflateRect(R, 2, 2);
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Color :=StyleServices.GetSystemColor(clHotLight);
Canvas.Rectangle(R);
end;
DrawIconEX(DC, LImageRect.Left, LImageRect.Top, Icon, BmpWidth, BmpHeight, 0, 0, DI_NORMAL);
DeleteObject(Icon);
end;
end;
end;
end;
if (LSysPopupItem.Checked) then
begin
LThemedMenu := TThemedMenu(integer(tmPopupCheckNormal) + integer(LSysPopupItem.Disabled));
if LSysPopupItem.RadioCheck then
LThemedMenu := TThemedMenu(integer(tmPopupBulletNormal) + integer(LSysPopupItem.Disabled));
LDetails := StyleServices.GetElementDetails(LThemedMenu);
StyleServices.GetElementSize(DC, LDetails, esActual, LSize);
LImageRect := Rect(0, 0, LSize.Width, LSize.Height);
RectVCenter(LImageRect, ItemRect2);
if DisplayCheckedGlyph then
begin
if not RightToLeft then
OffsetRect(LImageRect, 4, 0)
else
begin
LImageRect.Left := ItemRect2.Right - LSize.Width - 4;
LImageRect.Right := ItemRect2.Right;
end;
StyleServices.DrawElement(DC, LDetails, LImageRect);
end;
end;
{ Draw Text }
LTextFormat := [tfLeft, tfVerticalCenter, tfSingleLine, tfExpandTabs];//, tfHidePrefix];
// if (LMenuItem.Parent<>nil) then
// OutputDebugString(PChar(Format('LMenuItem.Parent %s IsItemHILITE %s', [LMenuItem.Parent.Caption, BoolToStr(IsItemHILITE(LMenuItem.Parent.Handle, LMenuItem.Parent.MenuIndex), True)])));
// if FEnterWithKeyboard then
// Exclude(LTextFormat, tfHidePrefix);
if not RightToLeft then
inc(LTextRect.Left, 28)
else
begin
LTextRect.Left := ItemRect2.Left;
LTextRect.Right := ItemRect2.Right - 28;
Exclude(LTextFormat, tfLeft);
Include(LTextFormat, tfRtlReading);
Include(LTextFormat, tfRight);
end;
if LImageWidth > 0 then
begin
if not RightToLeft then
LTextRect.Left := ItemRect2.Left + LImageWidth + 8 + 4
else
begin
LTextRect.Left := ItemRect2.Left;
LTextRect.Right := ItemRect2.Right - LImageWidth - 8;
end;
end;
LDetails := StyleServices.GetElementDetails(tmPopupItemNormal);
if isHot in State then
LDetails := StyleServices.GetElementDetails(tmPopupItemHot);
if isDisabled in State then
LDetails := StyleServices.GetElementDetails(tmPopupItemDisabled);
if LSysPopupItem.DefaultItem then
Canvas.Font.Style := [fsBold];
if LMenuItem <> nil then
DrawText(Canvas.Handle, LDetails, ItemText, LTextRect, LTextFormat)
else
begin
sShortCut := '';
// http://msdn.microsoft.com/en-us/library/ms647553%28v=VS.85%29.aspx#_win32_Menu_Shortcut_Keys
P := Pos(#9, ItemText);
if P > 1 then
begin
sShortCut := Copy(ItemText, P + 1, length(ItemText) - P);
DrawText(Canvas.Handle, LDetails, Copy(ItemText, 1, P), LTextRect, LTextFormat)
end
else
DrawText(Canvas.Handle, LDetails, ItemText, LTextRect, LTextFormat)
end;
{Draw vertical menu bar}
// LDetailsBar := StyleServices.GetElementDetails(tmPopupSeparator);
// LBitmapBar := TBitmap.Create;
// LBitmapBar.SetSize(LTextRect.Height, LTextRect.Height);
// LBitmapBar.PixelFormat := pf32bit;
// LBitmapBar.AlphaFormat := afDefined;
// LImageRect := Rect(0, 0, LBitmapBar.Width, LBitmapBar.Height);
// R:=LImageRect;
// try
// StyleServices.DrawElement(LBitmapBar.Canvas.Handle, LDetailsBar, Rect(0, 0, R.Width, R.Height));
// RotateBitmap(LBitmapBar, DegToRad(90), true);
// BitBlt(DC, LTextRect.Left - 6, LTextRect.Top, 1, LTextRect.Height, LBitmapBar.Canvas.Handle, round(LTextRect.Height / 2), 0, SRCCOPY);
// finally
// LBitmapBar.Free;
// end;
{ Draw ShortCut Text . }
if LMenuItem <> nil then
begin
if LMenuItem.ShortCut <> 0 then
begin
sShortCut := ShortCutToText(LMenuItem.ShortCut);
LTextRect := ItemRect2;
if RightToLeft then
begin
LTextRect.Left := ItemRect2.Left + 14;
LTextRect.Right := LTextRect.Left + Canvas.TextWidth(sShortCut);
end
else
begin
LTextRect.Left := ItemRect2.Right - 14 - Canvas.TextWidth(sShortCut);
LTextRect.Right := ItemRect2.Right;
end;
DrawText(Canvas.Handle, LDetails, sShortCut, LTextRect, LTextFormat);
end;
end
else if sShortCut <> '' then
begin
LTextRect := ItemRect2;
if RightToLeft then
begin
LTextRect.Left := ItemRect2.Left + 14;
LTextRect.Right := LTextRect.Left + Canvas.TextWidth(sShortCut);
end
else
begin
LTextRect.Left := ItemRect2.Right - 14 - Canvas.TextWidth(sShortCut);
LTextRect.Right := ItemRect2.Right;
end;
DrawText(Canvas.Handle, LDetails, sShortCut, LTextRect, LTextFormat);
end;
end;
procedure TSysPopupStyleHook.EraseItem(Canvas: TCanvas; const Index: integer; const ItemRect: TRect);
var
LBitmap: TBitmap;
LOffset: Integer;
begin
LBitmap := TBitmap.Create;
try
LBitmap.SetSize(SysControl.Width, SysControl.Height);
PaintBackground(LBitmap.Canvas);
LOffset := GetOffset(True);
BitBlt(Canvas.Handle, ItemRect.Left, ItemRect.Top - LOffset, ItemRect.Width, ItemRect.Height, LBitmap.Canvas.Handle, ItemRect.Left, ItemRect.Top - LOffset, SRCCOPY);
finally
LBitmap.Free;
end;
end;
function TSysPopupStyleHook.GetItemsCount: integer;
begin
Result := GetMenuItemCount(FMenu);
end;
function TSysPopupStyleHook.GetMenuFromHandle(AHandle: HWND): HMENU;
begin
Result := HMENU(SendMessage(AHandle, MN_GETHMENU, 0, 0));
end;
function TSysPopupStyleHook.GetRightToLeft: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_TYPE;
if GetMenuItemInfo(FMenu, 0, True, pMenuItemInfo) then
Result := ((pMenuItemInfo.fType and MFT_RIGHTORDER) = MFT_RIGHTORDER) or ((pMenuItemInfo.fType and MFT_RIGHTJUSTIFY) = MFT_RIGHTJUSTIFY);
end;
function TSysPopupStyleHook.GetSysPopupItem(Index: integer): TSysPopupItem;
begin
Result := nil;
if (Index > -1) and (index <= Count) then
begin
if Assigned(FSysPopupItem) then
FreeAndNil(FSysPopupItem);
FSysPopupItem := TSysPopupItem.Create(Self, SysControl, Index, FMenu);
Result := FSysPopupItem;
end;
end;
procedure TSysPopupStyleHook.PaintBackground(Canvas: TCanvas);
begin
StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tmPopupBorders), SysControl.ClientRect);
end;
procedure TSysPopupStyleHook.UpdateColors;
begin
inherited;
Font := Screen.MenuFont;
end;
type
TSubMenuItemInfo = record
Menu: HMENU;
WindowHandle: HWND;
ItemIndex: integer;
end;
var
SubMenuItemInfoArray: array of TSubMenuItemInfo;
procedure TSysPopupStyleHook.MNSELECTITEM(var Message: TMessage);
var
DC: HDC;
Canvas: TCanvas;
Index, Index2: integer;
i: WORD;
L: integer;
ParentItem: integer;
ParentPopup: HWND;
LMenu: HMENU;
ArrowHeight: Integer;
LDetails: TThemedElementDetails;
R, FClientRect: TRect;
LBitmap: TBitmap;
LButton: Byte;
LInitPos: TPoint;
begin
{ The undocumented MN_SELECTITEM Message:
This is the most importants message ,
Windows sends this message every time when the user
select an item (not clicking, only select) ...
wParam=Current Item Index .
lparam= may be it's unused (not sure).
}
//
Handled := False;
DC := 0;
Canvas := TCanvas.Create;
try
ParentPopup := 0;
ParentItem := -1;
DC := GetDC(Handle);
Canvas.Handle := DC;
Index := integer(Message.WParam);
//OutputDebugString(PChar(Format('MNSELECTITEM Index %d', [Index])));
if Assigned(Font) then
Canvas.Font := Font;
{ Out of index . }
if (Index > FCount - 1) or (Index < 0) then
begin
{ Make sure that wParam hold a valid Item Index .
if not .. then mouse is not on the PopupMenu
=> Remove Item highlight .
}
SetRedraw(True);
if (FPreviousHotItemIndex > -1) and (FPreviousHotItemIndex < FCount) then
DoDrawItem(Canvas, FPreviousHotItemIndex);
FPreviousHotItemIndex := -1;
Handled := True;
Exit;
end;
if not FItemsPainted then
begin
{ Items are not painted completely . }
if Index = 0 then
begin
{ draw up/dowm button }
if GetBottom(Count - 1) - SysControl.ClientRect.Bottom > 0 then
begin
LBitmap := TBitmap.Create;
FClientRect := SysControl.ClientRect;
LBitmap.SetSize(FClientRect.Height, FClientRect.Height);
LBitmap.PixelFormat := pf32bit;
LBitmap.AlphaFormat := afDefined;
if Assigned(Font) then
LBitmap.Canvas.Font := Font;
try
PaintBackground(LBitmap.Canvas);
FClientRect := SysControl.ClientRect;
if Offset > 0 then
LDetails := StyleServices.GetElementDetails(tsArrowBtnUpNormal)
else
LDetails := StyleServices.GetElementDetails(tsArrowBtnUpDisabled);
GetItemHeight();
ArrowHeight := trunc(FItemHeightCache / 2);
R := FClientRect;
R.Height := ArrowHeight;
StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, R);
if ItemIsVisible(Count - 1) then
LDetails := StyleServices.GetElementDetails(tsArrowBtnDownDisabled)
else
LDetails := StyleServices.GetElementDetails(tsArrowBtnDownNormal);
R := FClientRect;
R.Top := R.Top + R.Height - ArrowHeight;
R.Height := ArrowHeight;
StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, R);
BitBlt(DC, FClientRect.Left, FClientRect.Top, FClientRect.Width, FClientRect.Height, LBitmap.Canvas.Handle, 0, 0, SRCCOPY);
finally
LBitmap.Free;
end;
end;
end;
FPreviousHotItemIndex := Index;
DoDrawItem(Canvas, Index);
if (Index = Count - 1) then
begin
FItemsPainted := True;
FPreviousHotItemIndex := -1;
end;
Handled := True;
Exit;
end;
L := length(SubMenuItemInfoArray);
if L <> 0 then
begin
for i := 0 to L - 1 do
begin
{ Look for SubMenu Parent }
LMenu := SubMenuItemInfoArray[i].Menu;
if LMenu = FMenu then
begin
ParentPopup := SubMenuItemInfoArray[i].WindowHandle;
ParentItem := SubMenuItemInfoArray[i].ItemIndex;
Break;
end;
end;
end;
if (ParentPopup = Handle) then
SetRedraw(True) { Allow drawing the current PopupMenu }
else if ((ParentPopup <> Handle) and (FItemsPainted) and (ParentPopup <> 0)) then
begin
{
if user jump so fast from the parent PopupMenu to the
Child PopupMenu (SubMenu) , the hot item of parent Popup menu
will be draw as a normal item (not hot)..
So we need to repaint the hot item that drop the child popup menu.
}
if (not FParentSubItemPainted) and (ParentItem > -1) then
begin
SendMessage(ParentPopup, MN_SELECTITEM, ParentItem, 0);
FParentSubItemPainted := True;
end;
{ Don't Redraw the parent of the Current PopupMenu }
// SetRedraw(ParentPopup, False); //issue #81
end;
{ if Item can drop a sub Popup Menu }
if Items[Index].HasSubMenu then
begin
L := length(SubMenuItemInfoArray);
if L = 0 then
begin
SetLength(SubMenuItemInfoArray, 1);
SubMenuItemInfoArray[0].Menu := 0;
L := 1;
end;
LMenu := GetMenuFromHandle(Handle);
for i := 0 to L - 1 do
{ Avoid duplication }
if SubMenuItemInfoArray[i].Menu <> LMenu then
begin
inc(L);
SetLength(SubMenuItemInfoArray, L);
SubMenuItemInfoArray[L - 1].Menu := GetSubMenu(FMenu, Index);
SubMenuItemInfoArray[L - 1].WindowHandle := Handle;
SubMenuItemInfoArray[L - 1].ItemIndex := Index;
Break;
end;
end;
LInitPos.X := 0;
LInitPos.Y := 0;
Index2 := GetItemClicked(LButton, LInitPos);
if Index2 >= 0 then
Index := Index2;
{ If all Items are painted }
if FItemsPainted then
begin
{ In order to show / hide SubMenu ,we need to
process the default message handler . }
SetRedraw(False);
Message.Result := CallDefaultProc(Message);
SetRedraw(True);
end;
if FPreviousHotItemIndex <> Index then
begin
{ Draw Item normal . }
DoDrawItem(Canvas, FPreviousHotItemIndex);
{ Draw Item hot . }
DoDrawItem(Canvas, Index);
FPreviousHotItemIndex := Index;
end;
finally
Canvas.Handle := 0;
Canvas.Free;
if DC <> 0 then
ReleaseDC(Handle, DC);
end;
Handled := True;
end;
procedure TSysPopupStyleHook.WMPRINT(var Message: TMessage);
var
DC: HDC;
i: integer;
Canvas: TCanvas;
begin
FMenu := GetMenuFromHandle(Handle);
FCount := GetItemsCount;
if Message.WParam <> 0 then
DC := HDC(Message.WParam)
else
DC := GetDC(Handle);
Canvas := TCanvas.Create;
try
Canvas.Handle := DC;
PaintBackground(Canvas);
finally
Canvas.Handle := 0;
Canvas.Free;
if DC <> HDC(Message.WParam) then
ReleaseDC(Handle, DC);
end;
FEnterWithKeyboard := (GetKeyState(VK_MENU) < 0);
if Count > -1 then
begin
//exit;
//FCount:=48;
// for i := 0 to Count - 1 do
// begin
// GetMenuItemRect(0, FMenu, i, LRect);
// OutputDebugString(PChar(Format('Index %d Width %d Height %d Left %d Top %d', [i, LRect.Width, LRect.Height, LRect.Left, LRect.Top])));
// end;
for i := 0 + Offset to Count - 1 do
PostMessage(Handle, MN_SELECTITEM, i, 0);
end;
Handled := True;
end;
function IsItemSeparator(Menu: HMENU; const ItemIndex: integer): Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
{
Use this function instead of Items[Index].Separator .
==> Fast access in WM_KEYDOWN .
}
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_FTYPE;
if GetMenuItemInfo(Menu, ItemIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fType and MFT_SEPARATOR) = MFT_SEPARATOR;
end;
procedure TSysPopupStyleHook.GetNbSeparator(var PNbSeparator: Integer; const PIndex: Integer);
var
i: Integer;
begin
PNbSeparator := 0;
GetItemHeight();
GetSeparatorHeight();
for i := 0 to PIndex - 1 do
begin
if IsItemSeparator(Menu, i) then
Inc(PNbSeparator);
end;
end;
function TSysPopupStyleHook.GetMenuItemHeight(const Index: Integer): Integer;
var
LItemRect: TRect;
begin
GetMenuItemRect(0, FMenu, Index, LItemRect);
Result := LItemRect.Height;
end;
function TSysPopupStyleHook.GetBottom(const Index: Integer): Integer;
var
LItemRect: TRect;
P: TPoint;
begin
GetMenuItemRect(0, FMenu, Index, LItemRect);
P := Point(LItemRect.Left, LItemRect.Bottom);
ScreenToClient(Handle, P);
Result := P.Y;
end;
function TSysPopupStyleHook.GetOffset(UseCache: Boolean): Integer;
var
LNbSeparator: Integer;
begin
if (Offset = 0) and (GetBottom(Count - 1) <= SysControl.ClientRect.Bottom) then
begin
Result := 0;
exit;
end;
if UseCache then
if FOffsetCache <> 0 then
begin
Result := FOffsetCache;
exit;
end;
GetNbSeparator(LNbSeparator, Offset);
Result := ((Offset - LNbSeparator) * FItemHeightCache) + (LNbSeparator * FSeparatorHeightCache) - trunc(FItemHeightCache / 2);
if UseCache then
FOffsetCache := Result;
end;
procedure TSysPopupStyleHook.GetItemHeight();
var
i: Integer;
begin
if FItemHeightCache = 1 then
for i := 0 to Count - 1 do
if not IsItemSeparator(Menu, i) then
begin
FItemHeightCache := GetMenuItemHeight(i);
exit;
end;
if FItemHeightCache = 1 then
FItemHeightCache := 22;
end;
procedure TSysPopupStyleHook.GetSeparatorHeight();
var
i: Integer;
begin
if FSeparatorHeightCache = 1 then
for i := 0 to Count - 1 do
if IsItemSeparator(Menu, i) then
begin
FSeparatorHeightCache := GetMenuItemHeight(i);
exit;
end;
if FSeparatorHeightCache = 1 then
FSeparatorHeightCache := 8;
end;
procedure TSysPopupStyleHook.SetMaxOffset();
var
LGap, LBottom: Integer;
begin
{ Search gap }
LBottom := GetBottom(Count - 1);
{ No up/down button? }
LGap := LBottom - SysControl.ClientRect.Bottom;
if LGap <= 0 then
begin
Offset := 0;
exit;
end;
{ Search height to calc offset}
GetItemHeight();
{ FItemHeightCache is for 2 buttons up/down }
LGap := LGap + round(FItemHeightCache / 2);
if LGap <= 0 then
begin
Offset := 0;
exit;
end;
Offset := trunc(LGap / FItemHeightCache);
while not ItemIsVisible(Count - 1) do
Offset := Offset + 1;
end;
procedure TSysPopupStyleHook.RefreshMenu();
var
DC: HDC;
LBitmap: TBitmap;
i, ArrowHeight: Integer;
LDetails: TThemedElementDetails;
R, FClientRect: TRect;
begin
DC := 0;
LBitmap := TBitmap.Create;
FClientRect := SysControl.ClientRect;
LBitmap.SetSize(FClientRect.Height, FClientRect.Height);
LBitmap.PixelFormat := pf32bit;
LBitmap.AlphaFormat := afDefined;
if Assigned(Font) then
LBitmap.Canvas.Font := Font;
try
DC := GetDC(Handle);
PaintBackground(LBitmap.Canvas);
for i := Offset to Count - 1 do
begin
if ItemIsVisible(i) then
DoDrawItem(LBitmap.Canvas, i, True)
else
break;
end;
{ draw up/dowm button }
FClientRect := SysControl.ClientRect;
if Offset > 0 then
LDetails := StyleServices.GetElementDetails(tsArrowBtnUpNormal)
else
LDetails := StyleServices.GetElementDetails(tsArrowBtnUpDisabled);
ArrowHeight := trunc(FItemHeightCache / 2);
R := FClientRect;
R.Height := ArrowHeight;
StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, R);
if ItemIsVisible(Count - 1) then
LDetails := StyleServices.GetElementDetails(tsArrowBtnDownDisabled)
else
LDetails := StyleServices.GetElementDetails(tsArrowBtnDownNormal);
R := SysControl.ClientRect;
R.Top := R.Top + R.Height - ArrowHeight;
R.Height := ArrowHeight;
StyleServices.DrawElement(LBitmap.Canvas.Handle, LDetails, R);
BitBlt(DC, FClientRect.Left, FClientRect.Top, FClientRect.Width, FClientRect.Height, LBitmap.Canvas.Handle, 0, 0, SRCCOPY);
finally
LBitmap.Free;
if DC <> 0 then
ReleaseDC(Handle, DC);
end;
end;
function TSysPopupStyleHook.ItemIsVisible(const Index: Integer): Boolean;
var
LRect, LItemRect: TRect;
P: TPoint;
ClientRectHeight: Integer;
LOffset: Integer;
begin
result := True;
if (Index < 0) or (Index >= Count) then
Exit;
GetMenuItemRect(0, FMenu, Index, LItemRect);
P := Point(LItemRect.Left, LItemRect.Bottom);
ScreenToClient(Handle, P);
LOffset := GetOffset(True);
P.Y := P.Y - LOffset;
ClientRectHeight := GetClientRectHeight(LRect);
LRect.Height := ClientRectHeight;
//prevent draw not visible items on larger menus
Result := PtInRect (LRect, P);
if Result then
begin
P := Point(LItemRect.Left, LItemRect.Top);
ScreenToClient(Handle, P);
P.Y := P.Y - LOffset;
if ClientRectHeight > LItemRect.Height then
LRect.Height := ClientRectHeight - LItemRect.Height;
Result := PtInRect (LRect, P);
end;
end;
function TSysPopupStyleHook.GetClientRectHeight(var PValue: TRect): Integer;
begin
PValue := SysControl.ClientRect;
Result := PValue.Height;
{ Use offset? }
if GetBottom(Count - 1) - Result > 0 then
begin
GetItemHeight();
Result := Result - FItemHeightCache;
end;
end;
procedure TSysPopupStyleHook.SetOffset(PValue: Integer);
begin
FOffset := PValue;
FOffsetCache := 0;
end;
function TSysPopupStyleHook.GetItemClicked(var PButton: Byte; PInitPos: TPoint): Integer;
var
ArrowHeight, i: Integer;
R, LItemRect: TRect;
Pos: TPoint;
begin
PButton := 0;
Result := -1;
if (PInitPos.X = 0) and (PInitPos.Y = 0) then
Pos := GetMousePos()
else
begin
Pos := PInitPos;
ScreenToClient(Handle, Pos);
end;
R := SysControl.ClientRect;
if GetBottom(Count - 1) - R.Bottom > 0 then
begin
ArrowHeight := trunc(FItemHeightCache / 2);
if Pos.Y <= ArrowHeight then
begin
{ up button}
PButton := 1;
exit;
end;
if Pos.Y >= R.Bottom - ArrowHeight then
begin
{ down button}
PButton := 2;
exit;
end;
end;
Pos.Y := Pos.Y + GetOffset(True);
ClientToScreen(Handle, Pos);
for i := Offset to Count - 1 do
begin
GetMenuItemRect(0, FMenu, i, LItemRect);
if PtInRect (LItemRect, Pos) then
begin
Result := i;
exit;
end;
end;
if Result = -1 then
Result := -1;
end;
function TSysPopupStyleHook.GetMousePos(): TPoint;
begin
Result := Mouse.CursorPos;
ScreenToClient(Handle, Result);
end;
procedure TSysPopupStyleHook.WndProc(var Message: TMessage);
var
i: integer;
TopWin: HWND;
TopCntrl: TControl;
LButton: Byte;
LInitPos: TPoint;
Message2: TMessage;
LSwap: Boolean;
begin
//OutputDebugString(PChar(FormatDateTime('hh:nn:ss.zzz', Now)+' Msg = ' + IntToHex(Message.Msg, 4) + ' wParam = ' + IntToHex(Message.wParam, 8) + ' LParam = ' + IntToHex(Message.lParam, 8)));
// AddToLog(Message);
//Message.Result := CallDefaultProc(Message);
//Exit;
{
case Message.Msg of
WM_KEYFIRST..WM_KEYLAST:
begin
FEnterWithKeyboard := True;
end;
end;
}
case Message.Msg of
MN_SELECTITEM, WM_PRINT:
begin
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit; { Do not Dispatch . }
end;
end;
WM_PAINT:
begin
if not OverridePaint then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
SetRedraw(False);
Message.Result := CallDefaultProc(Message);
SetRedraw(True);
Exit; { Do not Dispatch . }
end;
WM_WINDOWPOSCHANGED:
begin
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
SetTimer(Handle, $93, 100, nil);
end;
WM_TIMER:
begin
if (FItemsPainted) and (Message.WParam = $93) then
begin
{ If PopupMenu is droped from MainMenu ,
MainMenu will send WM_KEYDOWN message
to the PopupMenu that cause the PopupMenu
to paint the first item as a hot item instead of
a normal item .
I use a timer to solve this problem .
}
FPaintFirstItemFromMenu := True;
KillTimer(Handle, $93);
end;
if Message.WParam = $201 then
{ down menu }
begin
LSwap := GetSystemMetrics(SM_SWAPBUTTON) <> 0;
if (LSwap and ((GetKeyState(VK_RBUTTON) and $80) <> 0)) or (not(LSwap) and ((GetKeyState(VK_LBUTTON) and $80) <> 0)) then
begin
if not ItemIsVisible(Count - 1) then
begin
Offset := Offset + 1;
RefreshMenu();
end
else
KillTimer(Handle, $201);
end
else
KillTimer(Handle, $201);
end;
if Message.WParam = $202 then
{ up menu }
begin
LSwap := GetSystemMetrics(SM_SWAPBUTTON) <> 0;
if (LSwap and ((GetKeyState(VK_RBUTTON) and $80) <> 0)) or (not(LSwap) and ((GetKeyState(VK_LBUTTON) and $80) <> 0)) then
begin
if Offset > 0 then
begin
Offset := Offset - 1;
RefreshMenu();
end
else
KillTimer(Handle, $202);
end
else
KillTimer(Handle, $202);
end;
end;
MN_BUTTONDOWN_UP, MN_DBLCLK:
begin
{ we should calc item/button pressed with mouse position }
LInitPos.X := 0;
LInitPos.Y := 0;
FKeyIndex := GetItemClicked(LButton, LInitPos);
case LButton of
0:
begin
{ Click on MenuItem}
if FKeyIndex = -1 then
begin
Message.Result := 0;
exit;
end;
Message2.Msg := MN_SELECTITEM;
Message2.wParam := FKeyIndex;
Message2.lParam := 0;
Message2.Result := 0;
CallDefaultProc(Message2);
Message2.Msg := WM_KEYDOWN;
Message2.wParam := VK_RETURN;
CallDefaultProc(Message2);
Message2.Msg := WM_KEYUP;
CallDefaultProc(Message2);
exit;
end;
1:
begin
{ Scroll up menu }
if Offset > 0 then
begin
FKeyIndex := -1;
Offset := Offset - 1;
RefreshMenu();
if FKeyIndex <> FPreviousHotItemIndex then
SendMessage(Handle, MN_SELECTITEM, FKeyIndex, 0);
Message.Result := 0;
SetTimer(Handle, $202, 150, nil);
exit;
end
else
begin
Message.Result := 0;
exit;
end;
end;
2:
begin
{ Scroll down }
if not ItemIsVisible(Count - 1) then
begin
Offset := Offset + 1;
FKeyIndex := -1;
RefreshMenu();
if FKeyIndex <> FPreviousHotItemIndex then
SendMessage(Handle, MN_SELECTITEM, FKeyIndex, 0);
SetTimer(Handle, $201, 150, nil);
Message.Result := 0;
exit;
end
else
begin
Message.Result := 0;
exit;
end;
end;
end;
end;
WM_KEYDOWN:
begin
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
FEnterWithKeyboard := True;
FMenu := GetMenuFromHandle(Handle);
if FPreviousHotItemIndex <> -1 then
FKeyIndex := FPreviousHotItemIndex;
case Message.WParam of
VK_DOWN:
if FPaintFirstItemFromMenu then
begin
if FKeyIndex >= GetMenuItemCount(Menu) - 1 then
FKeyIndex := -1;
Inc(FKeyIndex);
{ If the Current Item is Separator then
find the next valid item .
}
if IsItemSeparator(Menu, FKeyIndex) then
for i := FKeyIndex to GetMenuItemCount(Menu) - 1 do
if (not IsItemSeparator(Menu, i)) then
begin
FKeyIndex := i;
Break;
end;
if not ItemIsVisible(FKeyIndex) then
begin
if FKeyIndex <= 0 then
begin
if Offset <> 0 then
begin
Offset := 0;
end;
end
else
begin
if Offset >= GetMenuItemCount(Menu) then
Offset := GetMenuItemCount(Menu) - 1
else
begin
Offset := Offset + 1;
while not ItemIsVisible(FKeyIndex) do
Offset := Offset + 1;
end;
end;
RefreshMenu();
end;
SendMessage(Handle, MN_SELECTITEM, FKeyIndex, 0);
Message.Result := 0;
end;
VK_UP:
begin
if (FKeyIndex <= 0) or (FKeyIndex > GetMenuItemCount(Menu)) then
FKeyIndex := GetMenuItemCount(Menu);
Dec(FKeyIndex);
{ If the Current Item is Separator then
find the next valid item .
}
if IsItemSeparator(Menu, FKeyIndex) then
for i := FKeyIndex downto 0 do
if not IsItemSeparator(Menu, i) then
begin
FKeyIndex := i;
Break;
end;
if not ItemIsVisible(FKeyIndex) then
begin
if FKeyIndex <= 0 then
begin
if Offset <> 0 then
begin
Offset := 0
end;
end
else
begin
Offset := Offset - 1;
if Offset < 0 then
begin
{ Calc new offset value }
SetMaxOffset();
end
else
begin
while not ItemIsVisible(FKeyIndex) do
Offset := Offset - 1;
end;
end;
RefreshMenu();
end;
SendMessage(Handle, MN_SELECTITEM, FKeyIndex, 0);
Message.Result := 0;
end;
else
{ Calling the Default Message will cause
the WM_PAINT Message to be Sent to the PopupMenu Window }
Message.Result := CallDefaultProc(Message);
end;
Exit;
end;
WM_ERASEBKGND:
begin
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
SendMessage(Handle, WM_PRINT, Message.WParam, Message.lParam);
Message.Result := 1;
Exit; { Do not Dispatch . }
end;
WM_PRINTCLIENT:
begin
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
SendMessage(Handle, WM_PRINT, Message.WParam, Message.lParam);
Exit;
end;
WM_NCCALCSIZE, WM_NCPAINT:
begin
if Message.Msg= WM_NCCALCSIZE then
begin
if TWMNCCalcSize(Message).CalcValidRects then
begin
FNCRect := TWMNCCalcSize(Message).CalcSize_Params.rgrc[0];
//Message.Result := CallDefaultProc(Message);
//LRect := TWMNCCalcSize(Message).CalcSize_Params.rgrc0;
//OutputDebugString(PChar(Format('LRect.Height %d WParam %d', [FNCRect.Height, Message.WParam])));
end;
end;
if (not OverridePaint) or (not OverridePaintNC) then
begin
Message.Result := CallDefaultProc(Message);
Exit;
end;
if not StyleServicesEnabled then
begin
Handled := False;
Exit;
end;
Exit; { Do not Dispatch . }
end;
WM_DESTROY:
begin
TopWin := GetForegroundWindow;
if TopWin > 0 then
begin
{ The parent window that host menu should be repained !! }
if IsVCLControl(TopWin) then
begin
TopCntrl := FindControl(TopWin);
if Assigned(TopCntrl) then
begin
{
Must use TControl.Refresh to allow invalidating
others no TWinControl !
}
TopCntrl.Refresh;
end;
end
else if IsControlHooked(TopWin) then
begin
// AddToLog(IntToStr(TopWin));
InvalidateRect(TopWin, nil, False);
UpdateWindow(TopWin);
end;
end;
FVCLMenuItems := nil;
SetLength(SubMenuItemInfoArray, 0);
SubMenuItemInfoArray := nil;
Handled := False;
end;
//
// WM_NCDESTROY :
// begin
// end;
end;
inherited;
end;
{ TSysPopupItem }
constructor TSysPopupStyleHook.TSysPopupItem.Create(SysPopupStyleHook: TSysPopupStyleHook; SysParent: TSysControl; const Index: integer; const Menu: HMENU);
begin
inherited Create;
FSysPopupStyleHook := SysPopupStyleHook;
FMenu := Menu;
FHandle := SysParent.Handle;
FSysParent := SysParent;
FIndex := Index;
end;
destructor TSysPopupStyleHook.TSysPopupItem.Destroy;
begin
inherited;
end;
function TSysPopupStyleHook.TSysPopupItem.GetItemBitmap: HBITMAP;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := 0;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_BITMAP;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
begin
Result := pMenuItemInfo.hbmpItem;
if Result = 0 then
Result := pMenuItemInfo.hbmpUnchecked;
end;
end;
function TSysPopupStyleHook.TSysPopupItem.GetItemID: WORD;
begin
Result := 0;
if (FMenu > 0) and (FIndex > -1) then
Result := GetMenuItemID(FMenu, FIndex);
end;
function TSysPopupStyleHook.TSysPopupItem.GetItemRect: TRect;
begin
Result := Rect(0, 0, 0, 0);
if (FMenu > 0) and (FIndex > -1) then
GetMenuItemRect(0, FMenu, FIndex, Result);
end;
function TSysPopupStyleHook.TSysPopupItem.GetItemText: String;
var
Buffer: PChar;
StrSize: integer;
pMenuItemInfo: MENUITEMINFO;
begin
if VCLItem <> nil then
begin
Result := VCLItem.Caption;
Exit;
end;
{ Note:
The GetMenuString function has been superseded.
Use the GetMenuItemInfo function to retrieve the menu item text.
}
Result := '';
FillChar(pMenuItemInfo, SizeOf(MENUITEMINFO), Char(0));
pMenuItemInfo.cbSize := SizeOf(MENUITEMINFO);
pMenuItemInfo.fMask := MIIM_STRING or MIIM_FTYPE;
pMenuItemInfo.dwTypeData := nil;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
begin
//Fix for shell menus on W10
if (VCLMenuItems = nil) or (not (pMenuItemInfo.fType and MFT_OWNERDRAW = MFT_OWNERDRAW)) then
begin
{ The Size needed for the Buffer . }
StrSize := pMenuItemInfo.cch * 2 + 2;
GetMem(Buffer, StrSize);
try
pMenuItemInfo.dwTypeData := Buffer;
{ inc cch to get the last char . }
inc(pMenuItemInfo.cch);
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := String(Buffer);
finally
// OutputDebugString(PChar('StrSize '+IntToStr(StrSize)));
FreeMem(Buffer, StrSize);
end;
Exit;
end
else
begin
{ if the item is owner draw then we need another way to get
the item text since , when setting an item to ownerdraw windows
will destroy the dwTypeData that hold the text . }
FillChar(pMenuItemInfo, sizeof(MENUITEMINFO), Char(0));
pMenuItemInfo.cbSize := sizeof(MENUITEMINFO);
pMenuItemInfo.fMask := MIIM_DATA;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := String(PChar(pMenuItemInfo.dwItemData));
end;
end;
end;
function TSysPopupStyleHook.TSysPopupItem.GetVCLRealItem: TMenuItem;
var
i: integer;
VisibleItems: TList;
LVCLMenuItems: TMenuItem;
begin
{
Return the real menu item .
If MenuItem has the Visible property set to false
windows will delete this item but the VCL will not delete
the item from Items property .And thats can cause the item to be painted !
Do not access VCLMenuItems.Items[Index] directly
=> Instead , use this one: VCLItem .
}
VisibleItems := nil;
Result := nil;
LVCLMenuItems := VCLMenuItems;
if LVCLMenuItems <> nil then
begin
VisibleItems := TList.Create;
for i := 0 to LVCLMenuItems.Count - 1 do
begin
if LVCLMenuItems.Items[i].Visible then
VisibleItems.Add(LVCLMenuItems.Items[i]);
end;
end;
if Assigned(VisibleItems) then
begin
if (VisibleItems.Count > 0) and (FIndex < VisibleItems.Count) then
Result := VisibleItems.Items[FIndex];
FreeAndNil(VisibleItems);
end;
end;
function TSysPopupStyleHook.TSysPopupItem.GetVCLMenuItems: TMenuItem;
var
i, j: integer;
LPopupMenu: TPopupMenu;
LForm: TCustomForm;
LMenuItem: TMenuItem;
function GetChildPopup(Comp: TComponent): TMenuItem;
var
k: integer;
begin
Result := nil;
if Assigned(Comp) then
begin
for k := 0 to Comp.ComponentCount - 1 do
begin
if Comp.Components[k] is TPopupMenu then
begin
LPopupMenu := TPopupMenu(Comp.Components[k]);
if LPopupMenu.Handle = FMenu then
Exit(LPopupMenu.Items);
end
else if Comp.Components[k] is TMenuItem then
begin
LMenuItem := TMenuItem(Comp.Components[k]);
if LMenuItem.Handle = FMenu then
Exit(LMenuItem);
end;
if Comp.Components[k].ComponentCount > 0 then
Result := GetChildPopup(Comp.Components[k]);
if Assigned(Result) then
Exit;
end;
end;
end;
function GetMenuItem(AMenu: TMenuItem): TMenuItem;
var
LMenuItem: TMenuItem;
i: integer;
begin
if (AMenu.Handle = FMenu) then
Result := AMenu
else
begin
Result := nil;
i := 0;
while (Result = nil) and (i < AMenu.Count) do
begin
LMenuItem := AMenu.Items[i];
Result := GetMenuItem(LMenuItem);
inc(i);
end;
end;
end;
begin
Result := nil;
for i := 0 to PopupList.Count - 1 do
if TPopupMenu(PopupList.Items[i]).Handle = FMenu then
Exit(TPopupMenu(PopupList.Items[i]).Items);
for i := 0 to Screen.FormCount - 1 do
begin
LForm := Screen.Forms[i];
for j := 0 to LForm.ComponentCount - 1 do
begin
if LForm.Components[j] is TMenuItem then
begin
LMenuItem := TMenuItem(LForm.Components[j]);
Result := GetMenuItem(LMenuItem);
if Assigned(Result) then
Exit;
end
else if LForm.Components[j] is TPopupMenu then
begin
LPopupMenu := TPopupMenu(LForm.Components[j]);
if LPopupMenu.Handle = FMenu then
Exit(LPopupMenu.Items);
Result := GetMenuItem(LPopupMenu.Items);
if Assigned(Result) then
Exit;
end
else
begin
Result := GetChildPopup(LForm.Components[j]);
if Assigned(Result) then
Exit;
end;
end;
end;
end;
function TSysPopupStyleHook.TSysPopupItem.GetVCLMenuItemsFast: TMenuItem;
begin
if Assigned(FSysPopupStyleHook.FVCLMenuItems) then
Result := FSysPopupStyleHook.FVCLMenuItems
else
begin
Result := GetVCLMenuItems;
FSysPopupStyleHook.FVCLMenuItems := Result;
end;
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemDisabled: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_STATE;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fState and MFS_DISABLED = MFS_DISABLED) or (pMenuItemInfo.fState and MF_DISABLED = MF_DISABLED) or
(pMenuItemInfo.fState and MF_GRAYED = MF_GRAYED);
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemOwnerDraw: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(MENUITEMINFO), Char(0));
pMenuItemInfo.cbSize := sizeof(MENUITEMINFO);
pMenuItemInfo.fMask := MIIM_FTYPE;
pMenuItemInfo.dwTypeData := nil;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fType and MFT_OWNERDRAW = MFT_OWNERDRAW);
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemRadioCheck: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_FTYPE;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fType and MFT_RADIOCHECK) = MFT_RADIOCHECK;
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemChecked: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_STATE;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fState and MFS_CHECKED) = MFS_CHECKED;
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemContainsSubMenu: Boolean;
begin
Result := (GetSubMenu(FMenu, FIndex) > 0);
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemDefault: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
Result := False;
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_STATE;
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fState and MFS_DEFAULT) = MFS_DEFAULT;
end;
function TSysPopupStyleHook.TSysPopupItem.IsItemSeparator: Boolean;
var
pMenuItemInfo: TMenuItemInfo;
begin
FillChar(pMenuItemInfo, sizeof(pMenuItemInfo), Char(0));
pMenuItemInfo.cbSize := sizeof(TMenuItemInfo);
pMenuItemInfo.fMask := MIIM_FTYPE;
Result := False;
if (FIndex > -1) and (FIndex < GetMenuItemCount(FMenu) - 1) then
begin
if GetMenuItemInfo(FMenu, FIndex, True, pMenuItemInfo) then
Result := (pMenuItemInfo.fType and MFT_SEPARATOR) = MFT_SEPARATOR;
end;
end;
initialization
SubMenuItemInfoArray := nil;
{$IFDEF UseVCLStyleUtilsMenu}
{$IF CompilerVersion >= 27} // Disable XE6-XE7 menu syshooks
TStyleManager.SystemHooks := TStyleManager.SystemHooks - [shMenus];
{$IFEND CompilerVersion}
if StyleServices.Available then
TSysStyleManager.RegisterSysStyleHook('#32768', TSysPopupStyleHook);
{$ENDIF UseVCLStyleUtilsMenu}
finalization
{$IFDEF UseVCLStyleUtilsMenu}
TSysStyleManager.UnRegisterSysStyleHook('#32768', TSysPopupStyleHook);
{$ENDIF UseVCLStyleUtilsMenu}
end.
Reference in New Issue View Git Blame Copy Permalink