mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-18 07:29:30 +02:00
new interface method to attach a menu to window
git-svn-id: trunk@4733 -
This commit is contained in:
micha
parent
6526725baa
commit
615e8484ee
@ -36,7 +36,7 @@ uses
|
||||
{$IFDEF UseFPImage}
|
||||
FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
|
||||
{$ENDIF}
|
||||
LCLStrConsts, vclGlobals, LMessages, LCLType, LCLProc, LCLIntf, LResources,
|
||||
LCLStrConsts, vclGlobals, LMessages, LCLType, LCLProc, LResources,
|
||||
GraphType, GraphMath;
|
||||
|
||||
type
|
||||
@ -295,7 +295,7 @@ type
|
||||
|
||||
|
||||
{ TFont }
|
||||
|
||||
|
||||
TFont = class(TGraphicsObject)
|
||||
private
|
||||
FColor : TColor;
|
||||
@ -418,7 +418,7 @@ type
|
||||
TRegionData = record
|
||||
Handle : HRgn;
|
||||
Rect : TRect;
|
||||
|
||||
|
||||
{Polygon Region Info - not used yet}
|
||||
Polygon : PPoint;//Polygon Points
|
||||
NumPoints : Longint;//Number of Points
|
||||
@ -471,7 +471,7 @@ type
|
||||
(ex: TImage) sets it to False.
|
||||
OnProgress - Generic progress indicator event. Propagates out to TPicture
|
||||
and TImage OnProgress events.}
|
||||
|
||||
|
||||
TGraphic = class(TPersistent)
|
||||
private
|
||||
FModified: Boolean;
|
||||
@ -538,13 +538,13 @@ type
|
||||
|
||||
|
||||
{ TPicture }
|
||||
|
||||
|
||||
{ TPicture is a TGraphic container. It is used in place of a TGraphic if the
|
||||
graphic can be of any TGraphic class. LoadFromFile and SaveToFile are
|
||||
polymorphic. For example, if the TPicture is holding an Icon, you can
|
||||
LoadFromFile a bitmap file, where if the class is TIcon you could only read
|
||||
.ICO files.
|
||||
|
||||
|
||||
LoadFromFile - Reads a picture from disk. The TGraphic class created
|
||||
determined by the file extension of the file. If the file extension is
|
||||
not recognized an exception is generated.
|
||||
@ -747,7 +747,7 @@ type
|
||||
procedure Polyline(Points: PPoint; NumPts: Integer);
|
||||
procedure Polyline(const Points: array of TPoint);
|
||||
Procedure Rectangle(X1,Y1,X2,Y2 : Integer);
|
||||
Procedure Rectangle(const Rect: TRect);
|
||||
Procedure Rectangle(const Rect: TRect);
|
||||
Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer);
|
||||
Procedure RoundRect(const Rect : TRect; RX,RY : Integer);
|
||||
procedure TextOut(X,Y: Integer; const Text: String);
|
||||
@ -837,7 +837,7 @@ type
|
||||
|
||||
|
||||
{ TBitmap }
|
||||
|
||||
|
||||
{ Not completed!
|
||||
TBitmap is the data of an image. The image can be loaded from a file,
|
||||
stream or resource in .bmp (windows bitmap format) or .xpm (XPixMap format)
|
||||
@ -851,7 +851,7 @@ type
|
||||
bmisCreateingCanvas
|
||||
);
|
||||
TBitmapInternalState = set of TBitmapInternalStateFlag;
|
||||
|
||||
|
||||
TBitmap = class(TGraphic)
|
||||
private
|
||||
FCanvas: TCanvas;
|
||||
@ -951,15 +951,15 @@ type
|
||||
|
||||
|
||||
{ TPixmap }
|
||||
|
||||
|
||||
TPixmap = class(TBitmap)
|
||||
public
|
||||
function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
|
||||
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
|
||||
end;
|
||||
|
||||
|
||||
{ TPortableNetworkGraphic }
|
||||
|
||||
|
||||
TPortableNetworkGraphic = class(TBitmap)
|
||||
public
|
||||
{$IFDEF UseFPImage}
|
||||
@ -973,7 +973,7 @@ type
|
||||
procedure WriteStream(Stream: TStream; WriteSize: Boolean); override;
|
||||
function GetDefaultMimeType: string; override;
|
||||
end;
|
||||
|
||||
|
||||
{ TIcon }
|
||||
{
|
||||
@abstract()
|
||||
@ -1003,7 +1003,7 @@ function GetFPImageWriterForFileExtension(const FileExt: string
|
||||
type
|
||||
// Color / Identifier mapping
|
||||
TGetColorStringProc = procedure(const s:ansistring) of object;
|
||||
|
||||
|
||||
function ColorToIdent(Color: Longint; var Ident: String): Boolean;
|
||||
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
|
||||
function ColorToRGB(Color: TColor): Longint;
|
||||
@ -1085,7 +1085,7 @@ const
|
||||
implementation
|
||||
|
||||
uses
|
||||
TypInfo;
|
||||
TypInfo, LCLIntf;
|
||||
|
||||
function SendIntfMessage(LM_Message : integer; Sender : TObject;
|
||||
Data : pointer) : integer;
|
||||
@ -1259,6 +1259,9 @@ end.
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.94 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.93 2003/10/15 20:33:36 ajgenius
|
||||
add csForm, start fixing Style matching for syscolors and fonts
|
||||
|
||||
|
||||
@ -56,6 +56,10 @@ begin
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TInterfaceBase.AttachMenuToWindow(AMenu: TMenu);
|
||||
begin
|
||||
end;
|
||||
|
||||
function TInterfaceBase.BeginPaint(Handle: hWnd; Var PS : TPaintStruct) : hdc;
|
||||
begin
|
||||
Result:=GetDC(Handle);
|
||||
@ -1131,12 +1135,12 @@ end;
|
||||
|
||||
Function TInterfaceBase.InvalidateFrame(aHandle : HWND; ARect : pRect;
|
||||
bErase : Boolean; BorderWidth: integer) : Boolean;
|
||||
|
||||
|
||||
function Min(i1, i2: integer): integer;
|
||||
begin
|
||||
if i1<=i2 then Result:=i1 else Result:=i2;
|
||||
end;
|
||||
|
||||
|
||||
function Max(i1, i2: integer): integer;
|
||||
begin
|
||||
if i1<=i2 then Result:=i2 else Result:=i1;
|
||||
@ -1204,11 +1208,11 @@ begin
|
||||
Result := CreatePixmapIndirect(@IMGOK_Check[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonNo :
|
||||
Result := CreatePixmapIndirect(@IMG_NO[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonCancel :
|
||||
idButtonCancel :
|
||||
Result := CreatePixmapIndirect(@IMGCancel_X[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonHelp :
|
||||
Result := CreatePixmapIndirect(@IMGHELP[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonAll :
|
||||
idButtonAll :
|
||||
Result := CreatePixmapIndirect(@IMGAll_Check[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonYesToAll :
|
||||
Result := CreatePixmapIndirect(@IMGAll_Check[0], GetSysColor(COLOR_BTNFACE));
|
||||
@ -1216,9 +1220,9 @@ begin
|
||||
Result := CreatePixmapIndirect(@IMGCancel_X[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonAbort :
|
||||
Result := CreatePixmapIndirect(@IMGCancel_X[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonRetry :
|
||||
idButtonRetry :
|
||||
Result := CreatePixmapIndirect(@IMG_RETRY[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonIgnore :
|
||||
idButtonIgnore :
|
||||
Result := CreatePixmapIndirect(@IMG_IGNIORE[0], GetSysColor(COLOR_BTNFACE));
|
||||
idButtonClose :
|
||||
Result := CreatePixmapIndirect(@IMGClose[0], GetSysColor(COLOR_BTNFACE));
|
||||
@ -1243,9 +1247,9 @@ begin
|
||||
Result:= 0;
|
||||
end;
|
||||
|
||||
function TInterfaceBase.MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
|
||||
SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer;
|
||||
Rop: DWORD): Boolean;
|
||||
function TInterfaceBase.MaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
|
||||
SrcDC: HDC; XSrc, YSrc: Integer; Mask: HBITMAP; XMask, YMask: Integer;
|
||||
Rop: DWORD): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
end;
|
||||
@ -1301,7 +1305,7 @@ begin
|
||||
Result:=0;
|
||||
end;
|
||||
|
||||
function TInterfaceBase.MoveToEx(DC: HDC; X, Y: Integer;
|
||||
function TInterfaceBase.MoveToEx(DC: HDC; X, Y: Integer;
|
||||
OldPoint: PPoint): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
@ -1344,7 +1348,7 @@ Begin
|
||||
Result := False;
|
||||
End;
|
||||
|
||||
function TInterfaceBase.Pie(DC: HDC;
|
||||
function TInterfaceBase.Pie(DC: HDC;
|
||||
EllipseX1,EllipseY1,EllipseX2,EllipseY2,
|
||||
StartX,StartY,EndX,EndY: Integer): Boolean;
|
||||
begin
|
||||
@ -1370,14 +1374,14 @@ Begin
|
||||
ReallocMem(APoints,0);
|
||||
End;
|
||||
|
||||
function TInterfaceBase.Polygon(DC: HDC; Points: PPoint; NumPts: Integer;
|
||||
Winding: boolean): boolean;
|
||||
function TInterfaceBase.Polygon(DC: HDC; Points: PPoint; NumPts: Integer;
|
||||
Winding: boolean): boolean;
|
||||
begin
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
function TInterfaceBase.Polyline(DC: HDC; Points: PPoint;
|
||||
NumPts: Integer): boolean;
|
||||
function TInterfaceBase.Polyline(DC: HDC; Points: PPoint;
|
||||
NumPts: Integer): boolean;
|
||||
begin
|
||||
Result := false;
|
||||
end;
|
||||
@ -1496,9 +1500,9 @@ begin
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
function TInterfaceBase.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
|
||||
function TInterfaceBase.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
function TInterfaceBase.RightJustifyMenuItem(HndMenu: HMenu;
|
||||
@ -1590,7 +1594,7 @@ end;
|
||||
|
||||
function TInterfaceBase.SaveDC(DC: HDC) : Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
Function TInterfaceBase.ScreenToClient(Handle : HWND; var P : TPoint) : Integer;
|
||||
@ -1833,6 +1837,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.105 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.104 2003/10/16 23:54:27 marc
|
||||
Implemented new gtk keyevent handling
|
||||
|
||||
|
||||
@ -77,6 +77,8 @@ begin
|
||||
// Note: FItems is a TMenuItem. Using HandleNeeded will create all subitems.
|
||||
for i:=0 to Items.Count-1 do
|
||||
Items[i].HandleNeeded;
|
||||
// attach menu to window
|
||||
InterfaceObject.AttachMenuToWindow(Self);
|
||||
end;
|
||||
|
||||
procedure TMenu.DoChange(Source: TMenuItem; Rebuild: Boolean);
|
||||
@ -100,10 +102,10 @@ end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Function: TMenu.FindItem
|
||||
Params:
|
||||
Returns:
|
||||
Params:
|
||||
Returns:
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------}
|
||||
function TMenu.FindItem(AValue: Integer; Kind: TFindItemKind): TMenuItem;
|
||||
|
||||
@ -154,10 +156,10 @@ end;
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TMenu.GetChildren(Proc: TGetChildProc; Root: TComponent);
|
||||
var
|
||||
i : integer;
|
||||
i : integer;
|
||||
begin
|
||||
for i := 0 to FItems.Count - 1
|
||||
do if FItems[i].Owner = Root
|
||||
for i := 0 to FItems.Count - 1
|
||||
do if FItems[i].Owner = Root
|
||||
then Proc(TComponent (FItems [i]));
|
||||
end;
|
||||
|
||||
@ -220,10 +222,10 @@ end;
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
Function: TMenu.IsRightToLeft
|
||||
Params:
|
||||
Returns:
|
||||
Params:
|
||||
Returns:
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------}
|
||||
function TMenu.IsRightToLeft : Boolean;
|
||||
Begin
|
||||
@ -236,6 +238,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.20 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.19 2003/10/22 17:50:16 mattias
|
||||
updated rpm scripts
|
||||
|
||||
|
||||
@ -22,12 +22,12 @@
|
||||
}
|
||||
|
||||
{
|
||||
@author(TInterfaceBase - Marc Weustink <weus@quicknet.nl>)
|
||||
@author(TInterfaceBase - Marc Weustink <weus@quicknet.nl>)
|
||||
@created(13-Nov-1999)
|
||||
@lastmod(13-Nov-1999)
|
||||
|
||||
Detailed description of the Unit.
|
||||
}
|
||||
}
|
||||
|
||||
unit InterfaceBase;
|
||||
|
||||
@ -42,7 +42,7 @@ interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LCLStrConsts, LCLType, LCLProc, VCLGlobals, LMessages,
|
||||
GraphType, GraphMath;
|
||||
Menus, GraphType, GraphMath;
|
||||
|
||||
type
|
||||
|
||||
@ -65,6 +65,7 @@ type
|
||||
procedure WaitMessage; virtual; abstract;
|
||||
procedure AppInit; virtual; abstract;
|
||||
procedure AppTerminate; virtual; abstract;
|
||||
procedure AttachMenuToWindow(AMenu: TMenu); virtual;
|
||||
function IntSendMessage3(LM_Message : Integer; Sender : TObject; data : pointer) : integer; virtual; abstract;
|
||||
|
||||
function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc) : integer; virtual; abstract;
|
||||
@ -74,7 +75,7 @@ type
|
||||
{$I winapih.inc}
|
||||
{$UNDEF IF_BASE_MEMBER}
|
||||
end;
|
||||
|
||||
|
||||
type
|
||||
EInterfaceException = class(Exception);
|
||||
EInterfaceError = class(EInterfaceException);
|
||||
@ -99,13 +100,13 @@ type
|
||||
X, Y : Longint) : Longint;
|
||||
var
|
||||
PromptDialogFunction: TPromptDialogFunction;
|
||||
|
||||
|
||||
var
|
||||
InterfaceObject: TInterfaceBase;
|
||||
|
||||
implementation
|
||||
|
||||
uses Math;
|
||||
uses Math, LCLIntf;
|
||||
|
||||
{$I interfacebase.inc}
|
||||
|
||||
@ -120,6 +121,9 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.33 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.32 2003/08/18 19:24:18 mattias
|
||||
fixed TCanvas.Pie
|
||||
|
||||
|
||||
@ -38,7 +38,7 @@ Interface
|
||||
Uses
|
||||
Windows, Classes, LCLStrConsts, ComCtrls, Controls, Dialogs, DynHashArray,
|
||||
ExtCtrls, Forms, GraphMath, GraphType, InterfaceBase, LCLIntf, LCLType,
|
||||
LMessages, StdCtrls, SysUtils, VCLGlobals, Win32Def, Graphics;
|
||||
LMessages, StdCtrls, SysUtils, VCLGlobals, Win32Def, Graphics, Menus;
|
||||
|
||||
Type
|
||||
{ Virtual alignment-control record }
|
||||
@ -116,6 +116,7 @@ Type
|
||||
Procedure HandleEvents; Override;
|
||||
Procedure WaitMessage; Override;
|
||||
Procedure AppTerminate; Override;
|
||||
Procedure AttachMenuToWindow(AMenu: TMenu); Override;
|
||||
|
||||
function CreateTimer(Interval: integer; TimerFunc: TFNTimerProc) : integer; override;
|
||||
function DestroyTimer(TimerHandle: integer) : boolean; override;
|
||||
@ -131,7 +132,7 @@ Type
|
||||
Implementation
|
||||
|
||||
Uses
|
||||
Arrow, Buttons, Calendar, CListBox, Menus, Spin, WinExt;
|
||||
Arrow, Buttons, Calendar, CListBox, Spin, WinExt;
|
||||
|
||||
Type
|
||||
TEventType = (etNotify, etKey, etKeyPress, etMouseWheeel, etMouseUpDown);
|
||||
@ -180,6 +181,9 @@ End.
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.47 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.46 2003/10/23 07:45:49 micha
|
||||
cleanups; single parent window (single taskbar button)
|
||||
|
||||
|
||||
@ -1237,6 +1237,11 @@ begin
|
||||
Assert(False,'Trace:Destroy timer Result: '+ BOOL_RESULT[result]);
|
||||
end;
|
||||
|
||||
procedure TWin32Object.AttachMenuToWindow(AMenu: TMenu);
|
||||
begin
|
||||
Windows.SetMenu(TWinControl(AMenu.Owner).Handle, AMenu.Handle);
|
||||
end;
|
||||
|
||||
{ Private methods (in no significant order) }
|
||||
|
||||
{------------------------------------------------------------------------------
|
||||
@ -2092,7 +2097,6 @@ Begin
|
||||
Window := CreateMenu;
|
||||
FMenu := Window;
|
||||
Assert(False, Format('Trace:Main menu owner --> %S', [(TComponent(Sender).Owner As TWinControl).ClassName]));
|
||||
Windows.SetMenu(TWinControl(TComponent(Sender).Owner).Handle, Window);
|
||||
End;
|
||||
csMenuItem:
|
||||
Begin
|
||||
@ -2799,6 +2803,9 @@ End;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.121 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.120 2003/10/23 07:45:49 micha
|
||||
cleanups; single parent window (single taskbar button)
|
||||
|
||||
|
||||
19
lcl/menus.pp
19
lcl/menus.pp
@ -45,7 +45,7 @@ interface
|
||||
{$endif}
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LCLStrConsts, LCLIntf, LCLType, LCLProc, VCLGlobals,
|
||||
Classes, SysUtils, LCLStrConsts, LCLType, LCLProc, VCLGlobals,
|
||||
LMessages, ActnList, Graphics, ImgList;
|
||||
|
||||
|
||||
@ -54,7 +54,7 @@ type
|
||||
EMenuError = class(Exception);
|
||||
|
||||
TMenuItem = class;
|
||||
|
||||
|
||||
TMenuChangeEvent = procedure (Sender: TObject; Source: TMenuItem;
|
||||
Rebuild: Boolean) of object;
|
||||
|
||||
@ -88,8 +88,8 @@ type
|
||||
end;
|
||||
|
||||
TMenuActionLinkClass = class of TMenuActionLink;
|
||||
|
||||
|
||||
|
||||
|
||||
{ TMenuItem }
|
||||
|
||||
TMenuItem = class(TComponent)
|
||||
@ -269,8 +269,8 @@ type
|
||||
property Items;
|
||||
property OnChange;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
{ TPopupMenu }
|
||||
|
||||
TPopupMenu = class(TMenu)
|
||||
@ -314,6 +314,8 @@ procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
LCLIntf, InterfaceBase;
|
||||
|
||||
{ Menu command managment }
|
||||
|
||||
@ -378,7 +380,7 @@ initialization
|
||||
DesignerMenuItemClick:=nil;
|
||||
ActivePopupMenu:=nil;
|
||||
CommandPool := nil;
|
||||
|
||||
|
||||
finalization
|
||||
FreeThenNil(CommandPool);
|
||||
|
||||
@ -386,6 +388,9 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.53 2003/10/26 17:34:41 micha
|
||||
new interface method to attach a menu to window
|
||||
|
||||
Revision 1.52 2003/10/16 23:54:27 marc
|
||||
Implemented new gtk keyevent handling
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user