paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 11:19:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

convert LM_ATTACHMENU to interface method

Browse Source 
git-svn-id: trunk@5961 -
This commit is contained in:
micha 2004-09-10 18:58:24 +00:00
parent f03abe5a1e
commit 773ffa3278
11 changed files with 247 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lcl/include/custommemo.inc
View File

@ -31,6 +31,7 @@ begin
fCompStyle := csMemo;
FWordWrap := True;
FLines := TMemoStrings.Create(Self);
TMemoStrings(FLines).MemoWidgetClass := TWSCustomMemoClass(WidgetSetClass);
FVertScrollbar := TMemoScrollBar.Create(Self, sbVertical);
FHorzScrollbar := TMemoScrollBar.Create(Self, sbHorizontal);
SetInitialBounds(0,0,185,90);
@ -173,6 +174,9 @@ end;
{ =============================================================================
$Log$
Revision 1.29 2004/09/10 18:58:21 micha
convert LM_ATTACHMENU to interface method
Revision 1.28 2004/08/26 19:09:34 mattias
moved navigation key handling to TApplication and added options for custom navigation

8
lcl/include/menuitem.inc
View File

@ -125,7 +125,7 @@ begin
begin
Parent.HandleNeeded;
if Parent.HandleAllocated then
SendMsgToInterface(LM_ATTACHMENU, Self, nil);
TWSMenuItemClass(WidgetSetClass).AttachMenu(Self);
end;
if (Parent<>nil) then
begin
@ -1164,6 +1164,9 @@ end;
{ =============================================================================
$Log$
Revision 1.61 2004/09/10 18:58:21 micha
convert LM_ATTACHMENU to interface method
Revision 1.60 2004/09/10 09:43:13 micha
convert LM_SETLABEL message to interface methods
@ -1372,6 +1375,9 @@ end;
$Log$
Revision 1.61 2004/09/10 18:58:21 micha
convert LM_ATTACHMENU to interface method
Revision 1.60 2004/09/10 09:43:13 micha
convert LM_SETLABEL message to interface methods

6
lcl/interfaces/gtk/gtkint.pp
View File

@ -260,7 +260,6 @@ type
function GetValue(Sender : TObject; Data : pointer) : integer;virtual;
function SetValue(Sender : TObject; Data : pointer) : integer;virtual;
function SetProperties (Sender: TObject) : integer;virtual;
procedure AttachMenu(Sender: TObject);virtual;
procedure SetColorDialogColor(ColorSelection: PGtkColorSelection;
Color: TColor);virtual;
procedure WordWrap(DC: HDC; AText: PChar; MaxWidthInPixel: integer;
@ -354,7 +353,7 @@ uses
// GtkWSGrids,
// GtkWSImgList,
// GtkWSMaskEdit,
// GtkWSMenus,
GtkWSMenus,
// GtkWSPairSplitter,
GtkWSSpin,
GtkWSStdCtrls,
@ -459,6 +458,9 @@ end.
{ =============================================================================
$Log$
Revision 1.197 2004/09/10 18:58:22 micha
convert LM_ATTACHMENU to interface method
Revision 1.196 2004/09/10 17:59:57 micha
convert LM_APPENDTEXT to interface method

78
lcl/interfaces/gtk/gtkobject.inc
View File

@ -3144,8 +3144,6 @@ begin
LM_RECREATEWND : Result := RecreateWnd(sender);
LM_ATTACHMENU: AttachMenu(Sender);
LM_NB_UpdateTab: UpdateNotebookPageTab(nil,TCustomPage(Sender));
LM_LB_GETTOPINDEX: Result:=GetTopIndex(Sender);
@ -7616,79 +7614,6 @@ begin
end;
end;
{------------------------------------------------------------------------------
Method: TGtkWidgetSet.AttachMenu
Params: Sender : the lcl object which called this func
Returns: nothing
Attaches the calling Menu to its Parent
------------------------------------------------------------------------------}
procedure TGtkWidgetSet.AttachMenu(Sender: TObject);
var
//AccelKey: Integer;
//AccelGroup: PGTKAccelGroup;
MenuItem, ParentMenuWidget, ContainerMenu: PGtkWidget;
LCLMenuItem: TMenuItem;
procedure SetContainerMenuToggleSize;
var MenuClass: PGtkWidgetClass;
begin
if GtkWidgetIsA(ContainerMenu,GTK_TYPE_MENU) then begin
MenuClass:=GTK_WIDGET_CLASS(gtk_object_get_class(ContainerMenu));
if OldMenuSizeRequestProc=nil then begin
OldMenuSizeRequestProc:=MenuClass^.size_request;
end;
MenuClass^.size_request:=@MenuSizeRequest;
end;
end;
begin
LCLMenuItem:=TMenuItem(Sender);
//DebugLn('TGtkWidgetSet.AttachMenu START ',LCLMenuItem.Name,':',LCLMenuItem.ClassName,' Parent=',LCLMenuItem.Parent.Name,':',LCLMenuItem.Parent.ClassName);
with LCLMenuItem do
begin
MenuItem := PGtkWidget(Handle);
if MenuItem=nil then
RaiseException('TGtkWidgetSet.AttachMenu Handle=0');
ParentMenuWidget := PGtkWidget(Parent.Handle);
if ParentMenuWidget=nil then
RaiseException('TGtkWidgetSet.AttachMenu ParentMenuWidget=nil');
if GtkWidgetIsA(ParentMenuWidget,GTK_TYPE_MENU_BAR) then begin
// mainmenu (= a menu bar)
ContainerMenu:=ParentMenuWidget;
gtk_menu_bar_insert(ParentMenuWidget,MenuItem, LCLMenuItem.MenuIndex);
end
else begin
// menu item
// find the menu container
ContainerMenu := PGtkWidget(gtk_object_get_data(
PGtkObject(ParentMenuWidget),
'ContainerMenu'));
if ContainerMenu = nil then begin
if (GetParentMenu is TPopupMenu) and (Parent.Parent=nil) then begin
ContainerMenu:=PGtkWidget(GetParentMenu.Handle);
gtk_object_set_data(PGtkObject(ContainerMenu), 'ContainerMenu',
ContainerMenu);
end else begin
ContainerMenu := gtk_menu_new;
gtk_object_set_data(PGtkObject(ParentMenuWidget), 'ContainerMenu',
ContainerMenu);
gtk_menu_item_set_submenu(PGTKMenuItem(ParentMenuWidget),ContainerMenu);
end;
end;
gtk_menu_insert(ContainerMenu, MenuItem, LCLMenuItem.MenuIndex);
end;
SetContainerMenuToggleSize;
if GtkWidgetIsA(MenuItem, GTK_TYPE_RADIO_MENU_ITEM) then
RegroupMenuItem(HMENU(MenuItem),GroupIndex);
end;
//DebugLn('TGtkWidgetSet.AttachMenu END ',LCLMenuItem.Name,':',LCLMenuItem.ClassName);
end;
{------------------------------------------------------------------------------
Function: IsValidDC
Params: DC: a (LCL) devicecontext
@ -8823,6 +8748,9 @@ end;
{ =============================================================================
$Log$
Revision 1.548 2004/09/10 18:58:22 micha
convert LM_ATTACHMENU to interface method
Revision 1.547 2004/09/10 17:59:58 micha
convert LM_APPENDTEXT to interface method

76
lcl/interfaces/gtk/gtkwsmenus.pp
View File

@ -27,7 +27,14 @@ unit GtkWSMenus;
interface
uses
Menus, WSMenus, WSLCLClasses;
Menus, WSMenus, WSLCLClasses,
{$IFDEF gtk2}
glib2, gdk2pixbuf, gdk2, gtk2, Pango,
{$ELSE}
glib, gdk, gtk, {$Ifndef NoGdkPixbufLib}gdkpixbuf,{$EndIf} GtkFontCache,
{$ENDIF}
GtkInt, Classes, InterfaceBase, LCLType,
GTKWinApiWindow, gtkglobals, gtkproc;
type
@ -37,6 +44,7 @@ type
private
protected
public
class procedure AttachMenu(const AMenuItem: TMenuItem); override;
class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
end;
@ -67,6 +75,70 @@ type
implementation
procedure TGtkWSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
var
//AccelKey: Integer;
//AccelGroup: PGTKAccelGroup;
MenuItem, ParentMenuWidget, ContainerMenu: PGtkWidget;
procedure SetContainerMenuToggleSize;
var MenuClass: PGtkWidgetClass;
begin
if GtkWidgetIsA(ContainerMenu,GTK_TYPE_MENU) then begin
MenuClass:=GTK_WIDGET_CLASS(gtk_object_get_class(ContainerMenu));
if OldMenuSizeRequestProc=nil then begin
OldMenuSizeRequestProc:=MenuClass^.size_request;
end;
MenuClass^.size_request:=@MenuSizeRequest;
end;
end;
begin
//DebugLn('TGtkWidgetSet.AttachMenu START ',AMenuItem.Name,':',AMenuItem.ClassName,' Parent=',AMenuItem.Parent.Name,':',AMenuItem.Parent.ClassName);
with AMenuItem do
begin
MenuItem := PGtkWidget(Handle);
if MenuItem=nil then
RaiseException('TGtkWidgetSet.AttachMenu Handle=0');
ParentMenuWidget := PGtkWidget(Parent.Handle);
if ParentMenuWidget=nil then
RaiseException('TGtkWidgetSet.AttachMenu ParentMenuWidget=nil');
if GtkWidgetIsA(ParentMenuWidget,GTK_TYPE_MENU_BAR) then begin
// mainmenu (= a menu bar)
ContainerMenu:=ParentMenuWidget;
gtk_menu_bar_insert(ParentMenuWidget,MenuItem, AMenuItem.MenuIndex);
end
else begin
// menu item
// find the menu container
ContainerMenu := PGtkWidget(gtk_object_get_data(
PGtkObject(ParentMenuWidget),
'ContainerMenu'));
if ContainerMenu = nil then begin
if (GetParentMenu is TPopupMenu) and (Parent.Parent=nil) then begin
ContainerMenu:=PGtkWidget(GetParentMenu.Handle);
gtk_object_set_data(PGtkObject(ContainerMenu), 'ContainerMenu',
ContainerMenu);
end else begin
ContainerMenu := gtk_menu_new;
gtk_object_set_data(PGtkObject(ParentMenuWidget), 'ContainerMenu',
ContainerMenu);
gtk_menu_item_set_submenu(PGTKMenuItem(ParentMenuWidget),ContainerMenu);
end;
end;
gtk_menu_insert(ContainerMenu, MenuItem, AMenuItem.MenuIndex);
end;
SetContainerMenuToggleSize;
if GtkWidgetIsA(MenuItem, GTK_TYPE_RADIO_MENU_ITEM) then
TGtkWidgetSet(InterfaceObject).RegroupMenuItem(HMENU(MenuItem),GroupIndex);
end;
//DebugLn('TGtkWidgetSet.AttachMenu END ',AMenuItem.Name,':',AMenuItem.ClassName);
end;
procedure TGtkWSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
var
MenuItemWidget: PGtkWidget;
@ -84,7 +156,7 @@ initialization
// To improve speed, register only classes
// which actually implement something
////////////////////////////////////////////////////
// RegisterWSComponent(TMenuItem, TGtkWSMenuItem);
RegisterWSComponent(TMenuItem, TGtkWSMenuItem);
// RegisterWSComponent(TMenu, TGtkWSMenu);
// RegisterWSComponent(TMainMenu, TGtkWSMainMenu);
// RegisterWSComponent(TPopupMenu, TGtkWSPopupMenu);

9
lcl/interfaces/gtk/gtkwsstdctrls.pp
View File

@ -33,7 +33,9 @@ uses
{$ELSE}
glib, gdk, gtk, {$Ifndef NoGdkPixbufLib}gdkpixbuf,{$EndIf} GtkFontCache,
{$ENDIF}
WSStdCtrls, WSLCLClasses, GtkInt, Classes;
WSStdCtrls, WSLCLClasses, GtkInt, Classes,
GTKWinApiWindow, gtkglobals, gtkproc;
type
@ -218,11 +220,6 @@ type
implementation
uses
Buttons, PairSplitter, Math,
GTKWinApiWindow, ComCtrls, CListBox, Calendar, Arrow, Spin, CommCtrl,
ExtCtrls, FileCtrl, LResources, gtkglobals, gtkproc;
{ helper routines }

4
lcl/interfaces/win32/win32int.pp
View File

@ -147,7 +147,6 @@ Type
Function GetValue (Sender: TObject; Data: Pointer): Integer;
Function SetValue (Sender: TObject; Data: Pointer): Integer;
Function SetProperties(Sender: TObject): Integer;
Procedure AttachMenu(Sender: TObject);
Procedure AllocAndCopy(const BitmapInfo: Windows.TBitmap; const SrcRect: TRect; var Data: PByte; var Size: Cardinal);
procedure FillRawImageDescriptionColors(Desc: PRawImageDescription);
@ -281,6 +280,9 @@ End.
{ =============================================================================
$Log$
Revision 1.102 2004/09/10 18:58:22 micha
convert LM_ATTACHMENU to interface method
Revision 1.101 2004/09/10 14:38:29 micha
convert lm_gettext to new interface methods
remove lm_settext replacement settext methods in twidgetsets

143
lcl/interfaces/win32/win32object.inc
View File

@ -271,8 +271,6 @@ Begin
if Data<>nil then EnableWindow((Sender As TWinControl).Handle, boolean(Data^));
LM_RECREATEWND:
Result := RecreateWnd(TWinControl(Sender));
LM_ATTACHMENU:
AttachMenu(Sender);
//SH: think of TBitmap.handle!!!!
LM_SCREENINIT:
Begin
@ -2602,144 +2600,6 @@ begin
End;
End;
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.AttachMenu
Params: Sender - the lcl object which called this func
Returns: nothing
Attaches the calling Menu to its Parent
------------------------------------------------------------------------------}
Procedure TWin32WidgetSet.AttachMenu(Sender: TObject);
var MenuInfo: MENUITEMINFO;
ParentMenuHandle: HMenu;
ParentOfParent: HMenu;
Msg: TLMShortCut;
AMenuItem: TMenuItem;
function GetCheckBitmap(checked: boolean): HBitmap;
{TODO: create "checked" icon}
var hbmpCheck, hbmpTrans, hbmpMask: HBITMAP;
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
FillRect(hdcTransBitmap, RECT(0, 0, bmpWidth, bmpHeight), hbrTrans);
// blit menu icon transparently
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;
Begin
AMenuItem:=TMenuItem(Sender);
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!}
dwItemData:=integer(Sender);
// 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;
if AMenuItem.ShortCut <> 0 then
begin
Msg.Handle:=hSubMenu;
ShortCutToKey(AMenuItem.ShortCut, Msg.NewKey, Msg.NewModifier);
dwTypeData:=LPSTR(AMenuItem.Caption+#9+ShortCutToText(ShortCut(Msg.NewKey, Msg.NewModifier)));
end else begin
dwTypeData:=LPSTR(AMenuItem.Caption);
end;
cch:=StrLen(dwTypeData);
end else begin
fType:=MFT_SEPARATOR;
dwTypeData:=nil;
cch:=0;
end;
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.IndexOf(AMenuItem), true, @MenuInfo)) = 0 then
DebugLn('InsertMenuItem failed with error: ', IntToStr(Windows.GetLastError));
// owner could be a popupmenu too
if (TMenuItem(Sender).Owner is TWinControl) and
TWinControl(TMenuItem(Sender).Owner).HandleAllocated and
([csLoading,csDestroying] * TWinControl(TMenuItem(Sender).Owner).ComponentState = []) then
DrawMenuBar(TWinControl(TMenuItem(Sender).Owner).Handle);
End;
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.SetOwner
Params: Window - Window to which an owner will be set
@ -2760,6 +2620,9 @@ End;
{
$Log$
Revision 1.240 2004/09/10 18:58:22 micha
convert LM_ATTACHMENU to interface method
Revision 1.239 2004/09/10 17:59:58 micha
convert LM_APPENDTEXT to interface method

139
lcl/interfaces/win32/win32wsmenus.pp
View File

@ -36,7 +36,9 @@ uses
Menus,
////////////////////////////////////////////////////
WSMenus, WSLCLClasses,
Windows, Controls, Classes;
{TODO: remove when TLMShortCut removed from AttachMenu}
LMessages,
Windows, Controls, Classes, SysUtils, Win32Int, InterfaceBase, LCLProc;
type
@ -46,6 +48,7 @@ type
private
protected
public
class procedure AttachMenu(const AMenuItem: TMenuItem); override;
class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); override;
end;
@ -76,6 +79,140 @@ type
implementation
procedure TWin32WSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
var
MenuInfo: MENUITEMINFO;
ParentMenuHandle: HMenu;
ParentOfParent: HMenu;
Msg: TLMShortCut;
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
rectBitmap := RECT(0, 0, bmpWidth, bmpHeight);
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;
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!}
dwItemData:=PtrInt(AMenuItem);
// 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;
if AMenuItem.ShortCut <> 0 then
begin
Msg.Handle:=hSubMenu;
ShortCutToKey(AMenuItem.ShortCut, Msg.NewKey, Msg.NewModifier);
dwTypeData:=LPSTR(AMenuItem.Caption+#9+ShortCutToText(ShortCut(Msg.NewKey, Msg.NewModifier)));
end else begin
dwTypeData:=LPSTR(AMenuItem.Caption);
end;
cch:=StrLen(dwTypeData);
end else begin
fType:=MFT_SEPARATOR;
dwTypeData:=nil;
cch:=0;
end;
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.IndexOf(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
([csLoading,csDestroying] * TWinControl(AMenuItem.Owner).ComponentState = []) then
DrawMenuBar(TWinControl(AMenuItem.Owner).Handle);
end;
procedure TWin32WSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
var
MenuInfo: MENUITEMINFO;

5
lcl/lmessages.pp
View File

@ -70,7 +70,6 @@ const
LM_SETPROPERTIES = LM_ComUser+39; // update object to reflect current properties
LM_SETVALUE = LM_ComUser+40; // set actual value of object to visual object
LM_GETVALUE = LM_ComUser+41; // get actual value from visual object
LM_ATTACHMENU = LM_ComUser+42;
LM_TB_BUTTONCOUNT = LM_ComUser+45;
LM_INSERTTOOLBUTTON = LM_ComUser+46;
@ -878,7 +877,6 @@ begin
LM_SETPROPERTIES :Result:='LM_SETPROPERTIES';
LM_SETVALUE :Result:='LM_SETVALUE';
LM_GETVALUE :Result:='LM_GETVALUE';
LM_ATTACHMENU :Result:='LM_ATTACHMENU';
LM_TB_BUTTONCOUNT :Result:='LM_TB_BUTTONCOUNT';
LM_INSERTTOOLBUTTON :Result:='LM_INSERTTOOLBUTTON';
@ -1031,6 +1029,9 @@ end.
{
$Log$
Revision 1.82 2004/09/10 18:58:21 micha
convert LM_ATTACHMENU to interface method
Revision 1.81 2004/09/10 18:06:12 micha
remove LM_GETLABEL since it is not used (anymore)

5
lcl/widgetset/wsmenus.pp
View File

@ -53,6 +53,7 @@ type
TWSMenuItem = class(TWSLCLComponent)
public
class procedure AttachMenu(const AMenuItem: TMenuItem); virtual;
class procedure SetCaption(const AMenuItem: TMenuItem; const ACaption: string); virtual;
end;
TWSMenuItemClass = class of TWSMenuItem;
@ -75,6 +76,10 @@ type
implementation
procedure TWSMenuItem.AttachMenu(const AMenuItem: TMenuItem);
begin
end;
procedure TWSMenuItem.SetCaption(const AMenuItem: TMenuItem; const ACaption: string);
begin
end;