lazarus/lcl/interfaces/win32/win32wsmenus.pp
2005-05-21 15:58:44 +00:00

347 lines
12 KiB
ObjectPascal

{ $Id$}
{
*****************************************************************************
* Win32WSMenus.pp *
* --------------- *
* *
* *
*****************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.LCL, 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 Win32WSMenus;
{$mode objfpc}{$H+}
interface
uses
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// To get as little as posible circles,
// uncomment only when needed for registration
////////////////////////////////////////////////////
Menus, Forms,
////////////////////////////////////////////////////
WSMenus, WSLCLClasses,
Windows, Controls, Classes, SysUtils, Win32Int, Win32Proc, InterfaceBase, LCLProc;
type
{ TWin32WSMenuItem }
TWin32WSMenuItem = class(TWSMenuItem)
private
protected
public
class procedure AttachMenu(const AMenuItem: TMenuItem); override;
class function CreateHandle(const AMenuItem: TMenuItem): HMENU; override;
class procedure DestroyHandle(const AMenuItem: TMenuItem); override;
class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
class procedure SetShortCut(const AMenuItem: TMenuItem; const OldShortCut, NewShortCut: TShortCut); override;
end;
{ TWin32WSMenu }
TWin32WSMenu = class(TWSMenu)
private
protected
public
class function CreateHandle(const AMenu: TMenu): HMENU; override;
end;
{ TWin32WSMainMenu }
TWin32WSMainMenu = class(TWSMainMenu)
private
protected
public
end;
{ TWin32WSPopupMenu }
TWin32WSPopupMenu = class(TWSPopupMenu)
private
protected
public
class function CreateHandle(const AMenu: TMenu): HMENU; override;
class procedure Popup(const APopupMenu: TPopupMenu; const X, Y: integer); override;
end;
implementation
{ TWin32WSMenuItem }
procedure UpdateCaption(const AMenuItem: TMenuItem; ACaption: String);
var
MenuInfo: MENUITEMINFO;
begin
with MenuInfo do
begin
cbsize:=sizeof(MENUITEMINFO);
if ACaption <> '-' then
begin
fType := MFT_STRING;
{In Win32 Menu items that are created without a initial caption default to disabled,
the next three lines are to counter that.}
fMask:=MIIM_STATE;
GetMenuItemInfo(AMenuItem.Parent.Handle,
AMenuItem.Command, false, @MenuInfo);
if AMenuItem.Enabled then
fState := fState and DWORD(not (MFS_DISABLED or MFS_GRAYED));
fMask:=MIIM_TYPE or MIIM_STATE;
dwTypeData:=LPSTR(ACaption);
cch := StrLen(dwTypeData);
end
else fType := MFT_SEPARATOR;
end;
SetMenuItemInfo(AMenuItem.Parent.Handle, AMenuItem.Command, false, @MenuInfo);
// owner could be a popupmenu too
if (AMenuItem.Owner is TWinControl) and
TWinControl(AMenuItem.Owner).HandleAllocated and
TWinControl(AMenuItem.Owner).Visible and
([csLoading,csDestroying] * TWinControl(AMenuItem.Owner).ComponentState = []) then
DrawMenuBar(TWinControl(AMenuItem.Owner).Handle);
end;
procedure TWin32WSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
var
MenuInfo: MENUITEMINFO;
ParentMenuHandle: HMenu;
ParentOfParent: HMenu;
function GetCheckBitmap(checked: boolean): HBitmap;
{TODO: create "checked" icon}
var
hbmpCheck, hbmpTrans, hbmpMask: HBITMAP;
rectBitmap: Windows.RECT;
hbrTrans: HBRUSH;
OldCheckMark, OldOrigBitmap, OldTransBitmap: HBITMAP;
hdcNewBitmap, hdcOrigBitmap, hdcTransBitmap: HDC;
hdcScreen: HDC;
maxWidth, newWidth, bmpWidth: integer;
maxHeight, newHeight, bmpHeight: integer;
begin
maxWidth:=GetSystemMetrics(SM_CXMENUCHECK);
maxHeight:=GetSystemMetrics(SM_CYMENUCHECK);
if (maxWidth>=AMenuItem.Bitmap.Width) and (maxHeight>=AMenuItem.Bitmap.Height) then Result:=AMenuItem.Bitmap.Handle
else
begin
bmpWidth := AMenuItem.Bitmap.Width;
bmpHeight := AMenuItem.Bitmap.Height;
newWidth := min(maxWidth, bmpWidth);
newHeight := min(maxHeight, bmpHeight);
hdcScreen := GetDC(GetDesktopWindow);
hdcOrigBitmap := CreateCompatibleDC(hdcScreen);
hdcNewBitmap := CreateCompatibleDC(hdcScreen);
hdcTransBitmap := CreateCompatibleDC(hdcScreen);
hbmpCheck := CreateCompatibleBitmap(hdcScreen, newWidth, newHeight);
hbmpTrans := CreateCompatibleBitmap(hdcScreen, bmpWidth, bmpHeight);
hbmpMask := AMenuItem.Bitmap.MaskHandle;
ReleaseDC(GetDesktopWindow, hdcScreen);
hbrTrans := CreateSolidBrush(GetSysColor(COLOR_MENU));
OldOrigBitmap := SelectObject(hdcOrigBitmap, AMenuItem.Bitmap.Handle);
OldCheckmark := SelectObject(hdcNewBitmap, hbmpCheck);
OldTransBitmap := SelectObject(hdcTransBitmap, hbmpTrans);
// fill transparent-bitmap with transparent color
{$IFNDEF VER1_0}
rectBitmap := RECT(0, 0, bmpWidth, bmpHeight);
{$ELSE}
rectBitmap := Windows.Rect(RECT(0, 0, bmpWidth, bmpHeight));
{$ENDIF}
FillRect(hdcTransBitmap, rectBitmap, hbrTrans);
// blit menu icon transparently
TWin32WidgetSet(InterfaceObject).MaskBlt(hdcTransBitmap, 0, 0, bmpWidth,
bmpHeight, hdcOrigBitmap, 0, 0, hbmpMask, 0, 0);
// scale to correct size
StretchBlt(hdcNewBitmap, 0, 0, newWidth, newHeight, hdcTransBitmap, 0, 0, bmpWidth, bmpHeight, SRCCOPY);
// free mem
SelectObject(hdcOrigBitmap, OldOrigBitmap);
SelectObject(hdcTransBitmap, OldTransBitmap);
SelectObject(hdcNewBitmap, OldCheckmark);
DeleteDC(hdcOrigBitmap);
DeleteDC(hdcTransBitmap);
DeleteDC(hdcNewBitmap);
DeleteObject(hbmpTrans);
DeleteObject(hbrTrans);
{TODO: Add hbmpCheck into a list of object they must be deleted}
Result := hbmpCheck;
end;
end;
var
newCaption: string;
begin
ParentMenuHandle := AMenuItem.Parent.Handle;
{Following part fixes the case when an item is added in runtime
but the parent item has not defined the submenu flag (hSubmenu=0) }
if AMenuItem.Parent.Parent<>nil then
begin
ParentOfParent := AMenuItem.Parent.Parent.Handle;
with MenuInfo do begin
cbSize:=sizeof(MENUITEMINFO);
fMask:=MIIM_SUBMENU;
end;
GetMenuItemInfo(ParentOfParent, AMenuItem.Parent.Command,
false, @MenuInfo);
if MenuInfo.hSubmenu=0 then // the parent menu item is not yet defined with submenu flag
begin
MenuInfo.hSubmenu:=ParentMenuHandle;
SetMenuItemInfo(ParentOfParent, AMenuItem.Parent.Command,
false, MenuInfo);
end;
end;
with MenuInfo do begin
cbsize:=sizeof(MENUITEMINFO);
if AMenuItem.Enabled then fState:=MFS_ENABLED else fstate:=MFS_GRAYED;
if AMenuItem.Checked then fState:=fState or MFS_CHECKED;
fMask:=MIIM_ID or MIIM_DATA or MIIM_STATE or MIIM_TYPE;
wID:=AMenuItem.Command; {value may only be 16 bit wide!}
{$IFNDEF VER1_0}
dwItemData:=PtrInt(AMenuItem);
{$ELSE}
dwItemData:=Integer(AMenuItem);
{$ENDIF}
// Note: can't use "and MFT_STRING", because MFT_STRING is zero :-)
if (AMenuItem.Count > 0) then
begin
fMask := fMask or MIIM_SUBMENU;
hSubMenu := AMenuItem.Handle;
end else
hSubMenu := 0;
if AMenuItem.Caption <> '-' then
begin
fType:=MFT_STRING;
newCaption:=AMenuItem.Caption;
if AMenuItem.ShortCut <> 0 then
newCaption:=newCaption+#9+ShortCutToText(AMenuItem.ShortCut);
dwTypeData:=LPSTR(newCaption);
cch:=Length(newCaption);
end else begin
fType:=MFT_SEPARATOR;
dwTypeData:=nil;
cch:=0;
end;
if AMenuItem.RightJustify then fType := fType or MFT_RIGHTJUSTIFY;
if AmenuItem.HasIcon then {adds the menuitem icon}
begin
fMask:=fMask or MIIM_CHECKMARKS;
hbmpUnchecked:=GetCheckBitmap(false);
hbmpChecked:=0;
{TODO: add support for getting icon from SubmenuImages as it will be
implemented in LCL}
end;
end;
if dword(InsertMenuItem(ParentMenuHandle,
AMenuItem.Parent.VisibleIndexOf(AMenuItem), true, @MenuInfo)) = 0 then
DebugLn('InsertMenuItem failed with error: ', IntToStr(Windows.GetLastError));
// owner could be a popupmenu too
if (AMenuItem.Owner is TWinControl) and
TWinControl(AMenuItem.Owner).HandleAllocated and
TWinControl(AMenuItem.Owner).Visible and
([csLoading,csDestroying] * TWinControl(AMenuItem.Owner).ComponentState = []) then
DrawMenuBar(TWinControl(AMenuItem.Owner).Handle);
end;
function TWin32WSMenuItem.CreateHandle(const AMenuItem: TMenuItem): HMENU;
begin
Result := CreatePopupMenu;
end;
procedure TWin32WSMenuItem.DestroyHandle(const AMenuItem: TMenuItem);
var
AMenu: TMenu;
begin
{ not assigned when this the menuitem of a TMenu; handle is destroyed above }
if Assigned(AMenuItem.Parent) then
DeleteMenu(AMenuItem.Parent.Handle, AMenuItem.Command, MF_BYCOMMAND);
AMenu := AMenuItem.GetParentMenu;
if (AMenu<>nil) and (AMenu.Parent<>nil)
and (AMenu.Parent is TCustomForm)
and TCustomForm(AMenu.Parent).HandleAllocated
and TCustomForm(AMenu.Parent).Visible
and not (csDestroying in AMenu.Parent.ComponentState) then
DrawMenuBar(TCustomForm(AMenu.Parent).Handle);
end;
procedure TWin32WSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
var newCaption: string;
begin
newCaption := ACaption;
if AMenuItem.ShortCut <> 0 then
newCaption := newCaption+#9+ShortCutToText(AMenuItem.ShortCut);
UpdateCaption(AMenuItem, newCaption);
end;
procedure TWin32WSMenuItem.SetShortCut(const AMenuItem: TMenuItem;
const OldShortCut, NewShortCut: TShortCut);
var
NewKey: word;
NewModifier: TShiftState;
begin
UpdateCaption(AMenuItem, AMenuItem.Caption+#9+ShortCutToText(NewShortCut));
if (AMenuItem.Owner is TWinControl) and AMenuItem.HandleAllocated then
begin
ShortCutToKey(NewShortCut, NewKey, NewModifier);
SetAccelKey(TWinControl(AMenuItem.Owner).Handle, AMenuItem.Command, NewKey, NewModifier);
end else begin
DebugLn('TWin32WSMenuItem.SetShortCut: unable to set shortcut, menu has no window handle');
end;
end;
{ TWin32WSMenu }
function TWin32WSMenu.CreateHandle(const AMenu: TMenu): HMENU;
begin
Result := CreateMenu;
end;
{ TWin32WSPopupMenu }
function TWin32WSPopupMenu.CreateHandle(const AMenu: TMenu): HMENU;
begin
Result := CreatePopupMenu;
end;
procedure TWin32WSPopupMenu.Popup(const APopupMenu: TPopupMenu; const X, Y: integer);
var
MenuHandle, AppHandle: HWND;
begin
MenuHandle := APopupMenu.Handle;
AppHandle := TWin32WidgetSet(InterfaceObject).AppHandle;
GetWindowInfo(AppHandle)^.PopupMenu := MenuHandle;
TrackPopupMenuEx(MenuHandle, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON,
X, Y, AppHandle, Nil);
end;
initialization
////////////////////////////////////////////////////
// I M P O R T A N T
////////////////////////////////////////////////////
// To improve speed, register only classes
// which actually implement something
////////////////////////////////////////////////////
RegisterWSComponent(TMenuItem, TWin32WSMenuItem);
RegisterWSComponent(TMenu, TWin32WSMenu);
// RegisterWSComponent(TMainMenu, TWin32WSMainMenu);
RegisterWSComponent(TPopupMenu, TWin32WSPopupMenu);
////////////////////////////////////////////////////
end.