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

completed new TToolBar

Browse Source 
git-svn-id: trunk@5226 -
This commit is contained in:
mattias 2004-02-23 18:24:38 +00:00
parent 912d81b51e
commit add76d4e8b
34 changed files with 900 additions and 418 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -686,6 +686,7 @@ images/components/ttogglebox.ico -text svneol=unset#image/x-icon
images/components/ttogglebox.xpm -text svneol=native#image/x-xpixmap
images/components/ttoolbar.ico -text svneol=unset#image/x-icon
images/components/ttoolbar.xpm -text svneol=native#image/x-xpixmap
images/components/ttoolbutton.xpm -text svneol=native#image/x-xpixmap
images/components/ttrackbar.ico -text svneol=unset#image/x-icon
images/components/ttrackbar.xpm -text svneol=native#image/x-xpixmap
images/components/ttreeview.xpm -text svneol=native#image/x-xpixmap

11
components/jpeg/readme.txt
View File

@ -1,4 +1,15 @@
WARNING WARNING WARNING WARNING WARNING
This package is broken. Read further.
The pasjpeg code in the current fpc sources have a bug.
If you want jpeg, then you must use an older fpc and the jpeg from lazarus-ccr
on sourceforge. Not this package.
-------------------------------------------------------------------------------
The lazarus TJPEGImage is in lazjpeg.pas
It uses the pasjpeg and fpimage libs provided by FreePascal. See there for in

33
designer/controlselection.pp
View File

@ -213,6 +213,8 @@ type
cssOnlyVisualNeedsSelected,
cssOnlyInvisibleNeedsUpdate,
cssOnlyInvisibleSelected,
cssOnlyBoundLessNeedsUpdate,
cssOnlyBoundLessSelected,
cssBoundsNeedsUpdate,
cssBoundsNeedsSaving,
cssParentLevelNeedsUpdate,
@ -364,6 +366,7 @@ type
function OnlyNonVisualComponentsSelected: boolean;
function OnlyVisualComponentsSelected: boolean;
function OnlyInvisibleComponentsSelected: boolean;
function OnlyBoundLessComponentsSelected: boolean;
function LookupRootSelected: boolean;
// resizing, moving, aligning, mirroring, ...
@ -721,7 +724,7 @@ begin
FActiveGrabber:=nil;
FUpdateLock:=0;
FStates:=[cssOnlyNonVisualNeedsUpdate,cssOnlyVisualNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,cssOnlyBoundLessNeedsUpdate,
cssParentLevelNeedsUpdate,cssCacheGuideLines];
FRubberbandType:=rbtSelection;
FRubberbandCreationColor:=clMaroon;
@ -1762,7 +1765,7 @@ begin
if NewSelectedControl.DesignerForm<>FForm then Clear;
Result:=FControls.Add(NewSelectedControl);
FStates:=FStates+[cssOnlyNonVisualNeedsUpdate,cssOnlyVisualNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,cssOnlyBoundLessNeedsUpdate,
cssParentLevelNeedsUpdate,cssParentChildFlagsNeedUpdate];
if Count=1 then SetCustomForm;
if AComponent=FLookupRoot then Include(FStates,cssLookupRootSelected);
@ -1803,7 +1806,7 @@ begin
Items[Index].Free;
FControls.Delete(Index);
FStates:=FStates+[cssOnlyNonVisualNeedsUpdate,cssOnlyVisualNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,cssOnlyBoundLessNeedsUpdate,
cssParentLevelNeedsUpdate,cssParentChildFlagsNeedUpdate];
if Count=0 then SetCustomForm;
@ -1822,7 +1825,7 @@ begin
for i:=0 to FControls.Count-1 do Items[i].Free;
FControls.Clear;
FStates:=FStates+[cssOnlyNonVisualNeedsUpdate,cssOnlyVisualNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,
cssOnlyInvisibleNeedsUpdate,cssOnlyBoundLessNeedsUpdate,
cssParentLevelNeedsUpdate,cssParentChildFlagsNeedUpdate]
-[cssLookupRootSelected];
FForm:=nil;
@ -2013,7 +2016,7 @@ var
begin
if (Count=0) or (FForm=nil)
or LookupRootSelected
or OnlyInvisibleComponentsSelected then exit;
or OnlyBoundLessComponentsSelected then exit;
Diff:=DC.FormOrigin;
@ -2373,6 +2376,26 @@ begin
Result:=cssOnlyInvisibleSelected in FStates;
end;
function TControlSelection.OnlyBoundLessComponentsSelected: boolean;
var
i: Integer;
begin
if cssOnlyBoundLessNeedsUpdate in FStates then begin
Result:=true;
for i:=0 to FControls.Count-1 do
if ComponentBoundsDesignable(Items[i].Component) then begin
Result:=false;
break;
end;
if Result then
Include(FStates,cssOnlyBoundLessSelected)
else
Exclude(FStates,cssOnlyBoundLessSelected);
Exclude(FStates,cssOnlyBoundLessNeedsUpdate);
end else
Result:=cssOnlyBoundLessSelected in FStates;
end;
function TControlSelection.LookupRootSelected: boolean;
begin
Result:=cssLookupRootSelected in FStates;

12
designer/designerprocs.pas
View File

@ -89,6 +89,7 @@ var
function GetParentLevel(AControl: TControl): integer;
function ControlIsInDesignerVisible(AControl: TControl): boolean;
function ComponentIsInvisible(AComponent: TComponent): boolean;
function ComponentBoundsDesignable(AComponent: TComponent): boolean;
function GetParentFormRelativeTopLeft(Component: TComponent): TPoint;
function GetParentFormRelativeBounds(Component: TComponent): TRect;
@ -292,6 +293,17 @@ begin
Result:=false;
end;
function ComponentBoundsDesignable(AComponent: TComponent): boolean;
begin
Result:=(not ComponentIsInvisible(AComponent));
if Result and (AComponent is TControl) then begin
if [csDesignFixedBounds,csNoDesignVisible]*TControl(AComponent).ControlStyle
<>[]
then
Result:=false;
end;
end;
{ TDesignerDeviceContext }
function TDesignerDeviceContext.GetDCOrigin: TPoint;

28
ide/componentpalette.pas
View File

@ -38,9 +38,9 @@ unit ComponentPalette;
interface
uses
Classes, SysUtils, Dialogs, Graphics, ExtCtrls, Buttons, Menus, LResources,
AVL_Tree, LazarusIDEStrConsts, ComponentReg, DesignerProcs, IDEProcs,
PackageDefs;
Classes, SysUtils, Controls, Dialogs, Graphics, ExtCtrls, Buttons, Menus,
LResources, AVL_Tree, LazarusIDEStrConsts, ComponentReg, DesignerProcs,
IDEProcs, PackageDefs;
const
ComponentPaletteBtnWidth = 25;
@ -76,8 +76,8 @@ type
procedure OnPageRemovedComponent(Page: TBaseComponentPage;
Component: TRegisteredComponent); override;
procedure Update; override;
procedure CheckComponentHasIcon(AComponent: TComponent;
var Invisible: boolean);
procedure CheckComponentDesignerVisible(AComponent: TComponent;
var Invisible: boolean);
public
constructor Create;
destructor Destroy; override;
@ -273,25 +273,31 @@ begin
UpdateNoteBookButtons;
end;
procedure TComponentPalette.CheckComponentHasIcon(AComponent: TComponent;
var Invisible: boolean);
procedure TComponentPalette.CheckComponentDesignerVisible(
AComponent: TComponent; var Invisible: boolean);
var
RegComp: TRegisteredComponent;
AControl: TControl;
begin
RegComp:=FindComponent(AComponent.ClassName);
Invisible:=(RegComp<>nil) and (RegComp.PageName='');
if (AComponent is TControl) then begin
AControl:=TControl(AComponent);
Invisible:=(csNoDesignVisible in AControl.ControlStyle)
end else begin
RegComp:=FindComponent(AComponent.ClassName);
Invisible:=(RegComp<>nil) and (RegComp.PageName='');
end;
end;
constructor TComponentPalette.Create;
begin
inherited Create;
fComponents:=TAVLTree.Create(@CompareRegisteredComponents);
OnComponentIsInvisible:=@CheckComponentHasIcon;
OnComponentIsInvisible:=@CheckComponentDesignerVisible;
end;
destructor TComponentPalette.Destroy;
begin
if OnComponentIsInvisible=@CheckComponentHasIcon then
if OnComponentIsInvisible=@CheckComponentDesignerVisible then
OnComponentIsInvisible:=nil;
NoteBook:=nil;
fComponents.Free;

6
ide/exttooleditdlg.pas
View File

@ -506,7 +506,6 @@ begin
Height:=Self.ClientHeight-50-Top;
Caption:=lisEdtExtToolMacros;
OnResize:=@MacrosGroupboxResize;
Visible:=true;
end;
MacrosListbox:=TListbox.Create(Self);
@ -516,7 +515,6 @@ begin
SetBounds(5,5,MacrosGroupbox.ClientWidth-120,
MacrosGroupbox.ClientHeight-30);
OnClick:=@MacrosListboxClick;
Visible:=true;
end;
MacrosInsertButton:=TButton.Create(Self);
@ -527,7 +525,6 @@ begin
Caption:=lisEdtExtToolInsert;
OnClick:=@MacrosInsertButtonClick;
Enabled:=false;
Visible:=true;
end;
OkButton:=TButton.Create(Self);
@ -537,7 +534,6 @@ begin
SetBounds(270,Self.ClientHeight-40,100,25);
Caption:=lisLazBuildOk;
OnClick:=@OkButtonClick;
Visible:=true;
end;
CancelButton:=TButton.Create(Self);
@ -547,10 +543,10 @@ begin
SetBounds(390,OkButton.Top,100,25);
Caption:=dlgCancel;
OnClick:=@CancelButtonClick;
Visible:=true;
end;
OnResize:=@ExternalToolOptionDlgResize;
KeyPreview:=true;
OnKeyUp:=@FormKeyUp;
end;
fOptions:=TExternalToolOptions.Create;

68
ideintf/componenteditors.pas
View File

@ -27,7 +27,8 @@ unit ComponentEditors;
interface
uses
Classes, SysUtils, TypInfo, Forms, Controls, Menus, ExtCtrls, Grids, Buttons,
Classes, SysUtils, TypInfo,
Forms, Controls, Menus, ExtCtrls, Grids, Buttons, ComCtrls,
PropEdits, ObjInspStrConsts;
@ -192,6 +193,7 @@ type
procedure ExecuteVerb(Index: Integer); override;
end;
{ TNotebookComponentEditor
The default component editor for TCustomNotebook. }
TNotebookComponentEditor = class(TDefaultComponentEditor)
@ -213,6 +215,7 @@ type
function Notebook: TCustomNotebook; virtual;
end;
{ TPageComponentEditor
The default component editor for TCustomPage. }
TPageComponentEditor = class(TNotebookComponentEditor)
@ -237,6 +240,19 @@ type
end;
{ TToolBarComponentEditor
The default componenteditor fo TToolBar}
TToolBarComponentEditor = class(TDefaultComponentEditor)
protected
public
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
function ToolBar: TToolBar; virtual;
end;
{ Register a component editor }
type
TRegisterComponentEditorProc =
@ -815,6 +831,55 @@ begin
Result:=1;
end;
{ TToolBarComponentEditor }
procedure TToolBarComponentEditor.ExecuteVerb(Index: Integer);
var
NewStyle: TToolButtonStyle;
Hook: TPropertyEditorHook;
NewToolButton: TToolButton;
NewName: string;
CurToolBar: TToolBar;
begin
Hook:=nil;
if not GetHook(Hook) then exit;
case Index of
0: NewStyle:=tbsButton;
1: NewStyle:=tbsCheck;
2: NewStyle:=tbsSeparator;
else exit;
end;
CurToolBar:=ToolBar;
NewToolButton:=TToolButton.Create(CurToolBar.Owner);
NewName:=GetDesigner.CreateUniqueComponentName(NewToolButton.ClassName);
NewToolButton.Caption:=NewName;
NewToolButton.Name:=NewName;
NewToolButton.Style:=NewStyle;
NewToolButton.Parent:=CurToolBar;
Hook.ComponentAdded(NewToolButton,true);
GetDesigner.Modified;
end;
function TToolBarComponentEditor.GetVerb(Index: Integer): string;
begin
case Index of
0: Result:='New Button';
1: Result:='New Checkbutton';
2: Result:='New Separator';
else Result:='';
end;
end;
function TToolBarComponentEditor.GetVerbCount: Integer;
begin
Result:=3;
end;
function TToolBarComponentEditor.ToolBar: TToolBar;
begin
Result:=TToolBar(GetComponent);
end;
//------------------------------------------------------------------------------
procedure InternalFinal;
@ -836,6 +901,7 @@ initialization
RegisterComponentEditor(TCustomNotebook,TNotebookComponentEditor);
RegisterComponentEditor(TCustomPage,TPageComponentEditor);
RegisterComponentEditor(TStringGrid,TStringGridComponentEditor);
RegisterComponentEditor(TToolBar,TToolBarComponentEditor);
finalization
InternalFinal;

64
images/components/ttoolbutton.xpm Normal file
View File

@ -0,0 +1,64 @@
/* XPM */
static char * tbutton_xpm[] = {
"19 11 50 1",
" c None",
". c #F8F8F8",
"+ c #FFFFFF",
"@ c #EFEFEF",
"# c #F0F0F0",
"$ c #FCFCFC",
"% c #030303",
"& c #C1C1C1",
"* c #BCBCBC",
"= c #BDBDBD",
"- c #C5C5C5",
"; c #BFBFBF",
"> c #BEBEBE",
", c #BBBBBB",
"' c #CCCCCC",
") c #BABABA",
"! c #808080",
"~ c #000000",
"{ c #F4F4F4",
"] c #C8C8C8",
"^ c #C6C6C6",
"/ c #B8B8B8",
"( c #010101",
"_ c #C7C7C7",
": c #C4C4C4",
"< c #C0C0C0",
"[ c #040404",
"} c #060606",
"| c #050505",
"1 c #B9B9B9",
"2 c #020202",
"3 c #C9C9C9",
"4 c #C3C3C3",
"5 c #080808",
"6 c #070707",
"7 c #CACACA",
"8 c #B7B7B7",
"9 c #B6B6B6",
"0 c #CFCFCF",
"a c #FEFEFE",
"b c #7C7C7C",
"c c #8B8B8B",
"d c #767676",
"e c #828282",
"f c #878787",
"g c #7A7A7A",
"h c #7F7F7F",
"i c #888888",
"j c #7D7D7D",
"k c #898989",
".+@++#++++++++++$+%",
"+&*=-&;&;>,';);&;!~",
"{]>^/;(~&-~&~_:&;!~",
"+*&<=~;<[>}/|=1&;!~",
".;-,&2<&~;2~-:<&;!~",
".;-,&2<;%3~]~->&;!~",
"+*&<=~;4~1~<5=<&;!~",
"{]>^/;(6/7|*~1:&;!~",
"+&*=-&;*]8<^90)&;!~",
"abcdefghhhhhhhhijk~",
"~2~|~(~~~~~~~~~~2~ "};

22
images/components_images.lrs
View File

@ -2503,6 +2503,28 @@ LazarusResources.Add('ttoolbar','XPM',[
+'".##@++++++##@+.#@++++@ ",'#10'".###########@+.#####@ ",'#10'".@@@@@@@@@@@'
+'@+.@@@@@@ ",'#10'"++++++++++++++++++++ "};'#10
]);
LazarusResources.Add('ttoolbutton','XPM',[
'/* XPM */'#10'static char * tbutton_xpm[] = {'#10'"19 11 50 1",'#10'" '#9'c '
+'None",'#10'".'#9'c #F8F8F8",'#10'"+'#9'c #FFFFFF",'#10'"@'#9'c #EFEFEF",'#10
+'"#'#9'c #F0F0F0",'#10'"$'#9'c #FCFCFC",'#10'"%'#9'c #030303",'#10'"&'#9'c #'
+'C1C1C1",'#10'"*'#9'c #BCBCBC",'#10'"='#9'c #BDBDBD",'#10'"-'#9'c #C5C5C5",'
+#10'";'#9'c #BFBFBF",'#10'">'#9'c #BEBEBE",'#10'",'#9'c #BBBBBB",'#10'"'''#9
+'c #CCCCCC",'#10'")'#9'c #BABABA",'#10'"!'#9'c #808080",'#10'"~'#9'c #000000'
+'",'#10'"{'#9'c #F4F4F4",'#10'"]'#9'c #C8C8C8",'#10'"^'#9'c #C6C6C6",'#10'"/'
+#9'c #B8B8B8",'#10'"('#9'c #010101",'#10'"_'#9'c #C7C7C7",'#10'":'#9'c #C4C4'
+'C4",'#10'"<'#9'c #C0C0C0",'#10'"['#9'c #040404",'#10'"}'#9'c #060606",'#10
+'"|'#9'c #050505",'#10'"1'#9'c #B9B9B9",'#10'"2'#9'c #020202",'#10'"3'#9'c #'
+'C9C9C9",'#10'"4'#9'c #C3C3C3",'#10'"5'#9'c #080808",'#10'"6'#9'c #070707",'
+#10'"7'#9'c #CACACA",'#10'"8'#9'c #B7B7B7",'#10'"9'#9'c #B6B6B6",'#10'"0'#9
+'c #CFCFCF",'#10'"a'#9'c #FEFEFE",'#10'"b'#9'c #7C7C7C",'#10'"c'#9'c #8B8B8B'
+'",'#10'"d'#9'c #767676",'#10'"e'#9'c #828282",'#10'"f'#9'c #878787",'#10'"g'
+#9'c #7A7A7A",'#10'"h'#9'c #7F7F7F",'#10'"i'#9'c #888888",'#10'"j'#9'c #7D7D'
+'7D",'#10'"k'#9'c #898989",'#10'".+@++#++++++++++$+%",'#10'"+&*=-&;&;>,'';);'
+'&;!~",'#10'"{]>^/;(~&-~&~_:&;!~",'#10'"+*&<=~;<[>}/|=1&;!~",'#10'".;-,&2<&~'
+';2~-:<&;!~",'#10'".;-,&2<;%3~]~->&;!~",'#10'"+*&<=~;4~1~<5=<&;!~",'#10'"{]>'
+'^/;(6/7|*~1:&;!~",'#10'"+&*=-&;*]8<^90)&;!~",'#10'"abcdefghhhhhhhhijk~",'#10
+'"~2~|~(~~~~~~~~~~2~ "};'#10
]);
LazarusResources.Add('ttrackbar','XPM',[
'/* XPM */'#10'static char * ttrackbar_xpm[] = {'#10'"21 12 5 1",'#10'" '#9'c'
+' None",'#10'".'#9'c #FFFFFF",'#10'"+'#9'c #C0C0C0",'#10'"@'#9'c #808080",'

13
lcl/buttons.pp
View File

@ -63,20 +63,14 @@ type
FCancel : Boolean;
FDefault : Boolean;
FModalResult : TModalResult;
FOnMouseLeave: TNotifyEvent;
FOnMouseEnter: TNotifyEvent;
FShortCut : TLMShortcut;
Procedure SetDefault(Value : Boolean);
procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
procedure WMDefaultClicked(var Message: TLMessage); message LM_CLICKED;
protected
procedure Click; override;
procedure CreateWnd; override;
procedure DoSendBtnDefault; virtual;
property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
procedure SetParent(AParent: TWinControl); override;
procedure SetText(const Value: TCaption); override;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
@ -229,8 +223,8 @@ type
procedure SetLayout(const Value: TButtonLayout);
procedure SetTransparent(const Value: boolean);
procedure CMButtonPressed(var Message: TLMessage); message CM_BUTTONPRESSED;
procedure CMMouseEnter(var Message: TLMessage); message CM_MouseEnter;
procedure CMMouseLeave(var Message: TLMessage); message CM_MouseLeave;
procedure MouseEnter; override;
procedure MouseLeave; override;
procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
protected
FState: TButtonState;
@ -332,6 +326,9 @@ end.
{ =============================================================================
$Log$
Revision 1.60 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.59 2004/02/22 10:43:20 mattias
added child-parent checks

11
lcl/comctrls.pp
View File

@ -816,8 +816,6 @@ type
procedure SetWrap(Value: Boolean);
procedure SetMouseInControl(NewMouseInControl: Boolean);
procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
procedure CMMouseEnter(var Message: TLMessage); message CM_MouseEnter;
procedure CMMouseLeave(var Message: TLMessage); message CM_MouseLeave;
protected
FToolBar: TToolBar;
function GetActionLinkClass: TControlActionLinkClass; override;
@ -828,6 +826,8 @@ type
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Paint; override;
procedure RefreshControl; virtual;
@ -837,6 +837,7 @@ type
procedure SetParent(AParent: TWinControl); override;
procedure UpdateVisibleToolbar;
function GroupAllUpAllowed: boolean;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
public
constructor Create(TheOwner: TComponent); override;
function CheckMenuDropdown: Boolean; dynamic;
@ -893,6 +894,7 @@ type
TToolBar = class(TToolWindow)
private
FButtonHeight: Integer;
FRealizedButtonHeight: integer;
FButtons: TList;
FButtonWidth: Integer;
FDisabledImageChangeLink: TChangeLink;
@ -958,6 +960,8 @@ type
procedure FlipChildren(AllLevels: Boolean); override;
procedure BeginUpdate; virtual;
procedure EndUpdate; virtual;
procedure Paint; override;
procedure SetButtonSize(NewButtonWidth, NewButtonHeight: integer);
public
property ButtonCount: Integer read GetButtonCount;
property Buttons[Index: Integer]: TToolButton read GetButton;
@ -2235,6 +2239,9 @@ end.
{ =============================================================================
$Log$
Revision 1.115 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.114 2004/02/22 16:22:53 mattias
fixed old toolbar compilation

88
lcl/controls.pp
View File

@ -262,7 +262,10 @@ type
csReflector,
csActionClient,
csMenuEvents,
csNoFocus);
csNoFocus,
csDesignNoSmoothResize, // no WYSIWYG resizing in designer
csDesignFixedBounds // control can not be moved nor resized in designer
);
TControlStyle = set of TControlStyleType;
const
@ -632,7 +635,7 @@ type
TControlShowHintEvent = procedure(Sender: TObject; HintInfo: Pointer) of object;
TContextPopupEvent = procedure(Sender: TObject; MousePos: TPoint; var Handled: Boolean) of object;
TControlFlag = (
cfRequestAlignNeeded,
cfClientWidthLoaded,
@ -805,8 +808,8 @@ type
procedure LockBaseBounds;
procedure UnlockBaseBounds;
procedure UpdateAnchorRules;
procedure ChangeBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); virtual;
procedure ChangeBounds(ALeft, ATop, AWidth, AHeight: integer); virtual;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); virtual;
procedure ChangeScale(M,D : Integer); dynamic;
Function CanAutoSize(var NewWidth, NewHeight : Integer): Boolean; virtual;
procedure SetAlignedBounds(aLeft, aTop, aWidth, aHeight: integer); virtual;
@ -881,6 +884,9 @@ type
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); dynamic;
procedure MouseMove(Shift: TShiftState; X,Y: Integer); Dynamic;
procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); dynamic;
procedure MouseEnter; virtual;
procedure MouseLeave; virtual;
procedure CaptureChanged; virtual;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
Function CanTab: Boolean; virtual;
Function Focused : Boolean; dynamic;
@ -974,6 +980,7 @@ type
Procedure SetZOrder(TopMost: Boolean); virtual;
function HandleObjectShouldBeVisible: boolean; virtual;
procedure InitiateAction; virtual;
property MouseEntered: Boolean read FMouseEntered;
public
// Event lists
procedure RemoveAllControlHandlersOfObject(AnObject: TObject);
@ -1287,7 +1294,7 @@ type
procedure CreateComponent(TheOwner: TComponent); virtual;
procedure DestroyComponent; virtual;
procedure DoConstraintsChange(Sender : TObject); override;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight : integer); override;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
procedure DoAutoSize; Override;
procedure GetChildren(Proc : TGetChildProc; Root : TComponent); override;
function ChildClassAllowed(ChildClass: TClass): boolean; override;
@ -1682,7 +1689,6 @@ procedure SetCaptureControl(Control : TControl);
function GetCaptureControl : TControl;
procedure CancelDrag;
var
NewStyleControls : Boolean;
Mouse : TMouse;
@ -2023,32 +2029,51 @@ begin
end;
procedure SetCaptureControl(Control : TControl);
var
OldCaptureWinControl: TWinControl;
NewCaptureWinControl: TWinControl;
begin
{$IFDEF VerboseMouseCapture}
write('SetCaptureControl');
if CaptureControl<>nil then
write(' Old=',CaptureControl.Name,':',CaptureControl.ClassName)
else
write(' Old=nil');
if Control<>nil then
write(' New=',Control.Name,':',Control.ClassName)
else
write(' New=nil');
writeln('');
{$ENDIF}
ReleaseCapture;
CaptureControl := nil;
if Control <> nil
then begin
if not (Control is TWinControl)
then begin
if Control.Parent = nil then Exit;
CaptureControl := Control;
Control := Control.Parent;
end;
SetCapture(TWinControl(Control).Handle);
if CaptureControl=Control then exit;
if Control=nil then begin
{$IFDEF VerboseMouseCapture}
write('SetCaptureControl Only ReleaseCapture');
{$ENDIF}
// just unset the capturing, intf call not needed
CaptureControl:=nil;
ReleaseCapture;
exit;
end;
OldCaptureWinControl:=FindOwnerControl(GetCapture);
if Control is TWinControl then
NewCaptureWinControl:=TWinControl(Control)
else
NewCaptureWinControl:=Control.Parent;
if NewCaptureWinControl=nil then begin
{$IFDEF VerboseMouseCapture}
write('SetCaptureControl Only ReleaseCapture');
{$ENDIF}
// just unset the capturing, intf call not needed
CaptureControl:=nil;
ReleaseCapture;
exit;
end;
if NewCaptureWinControl=OldCaptureWinControl then begin
{$IFDEF VerboseMouseCapture}
write('SetCaptureControl Keep WinControl ',NewCaptureWinControl.Name,':',NewCaptureWinControl.ClassName,
' switch Control ',Control.Name,':',Control.ClassName);
{$ENDIF}
// just change the CaptureControl, intf call not needed
CaptureControl:=Control;
exit;
end;
// switch capture control
{$IFDEF VerboseMouseCapture}
write('SetCaptureControl Switch to WinControl=',NewCaptureWinControl.Name,':',NewCaptureWinControl.ClassName,
' and Control=',Control.Name,':',Control.ClassName);
{$ENDIF}
CaptureControl:=Control;
ReleaseCapture;
SetCapture(TWinControl(NewCaptureWinControl).Handle);
end;
procedure CancelDrag;
@ -2366,6 +2391,9 @@ end.
{ =============================================================================
$Log$
Revision 1.182 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.181 2004/02/23 08:19:04 micha
revert intf split

2
lcl/forms.pp
View File

@ -778,6 +778,8 @@ type
procedure IconChanged(Sender: TObject);
procedure Idle;
function InvokeHelp(Command: Word; Data: Longint): Boolean;
function GetControlAtMouse: TControl;
procedure UpdateMouseControl(NewMouseControl: TControl);
procedure MouseIdle(const CurrentControl: TControl);
procedure SetCaptureExceptions(const AValue: boolean);
procedure SetHint(const AValue: string);

65
lcl/include/application.inc
View File

@ -237,21 +237,9 @@ end;
Handles mouse Idle
------------------------------------------------------------------------------}
procedure TApplication.MouseIdle(const CurrentControl: TControl);
var
CaptureControl: TControl;
IsOther: Boolean;
begin
CaptureControl := GetCaptureControl;
if FMouseControl <> CurrentControl then
begin
IsOther:=((FMouseControl <> nil) and (CaptureControl = nil)) or
((CaptureControl <> nil) and (FMouseControl = CaptureControl));
if IsOther and (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
FMouseControl := CurrentControl;
if IsOther and (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
if FMouseControl <> CurrentControl then begin
UpdateMouseControl(CurrentControl);
end;
end;
@ -284,17 +272,9 @@ end;
------------------------------------------------------------------------------}
procedure TApplication.Idle;
var
P: TPoint;
Done: Boolean;
CurrentControl: TControl;
begin
GetCursorPos(P);
CurrentControl := FindDragTarget(P, True);
if (CurrentControl <> nil)
and (csDesigning in CurrentControl.ComponentState)
then CurrentControl := nil;
MouseIdle(CurrentControl);
MouseIdle(GetControlAtMouse);
Done := True;
if Assigned(FOnIdle) then FOnIdle(Self, Done);
@ -352,6 +332,34 @@ begin
end;
end;
{------------------------------------------------------------------------------
function TApplication.GetControlAtMouse: TControl;
------------------------------------------------------------------------------}
function TApplication.GetControlAtMouse: TControl;
var
P: TPoint;
begin
GetCursorPos(P);
Result := FindDragTarget(P, True);
if (Result <> nil) and (csDesigning in Result.ComponentState) then
Result := nil;
end;
{------------------------------------------------------------------------------
procedure TApplication.UpdateMouseControl(NewMouseControl: TControl);
------------------------------------------------------------------------------}
procedure TApplication.UpdateMouseControl(NewMouseControl: TControl);
begin
if FMouseControl=NewMouseControl then exit;
if (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
FMouseControl := NewMouseControl;
if (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
end;
{------------------------------------------------------------------------------
Method: TApplication.SetIcon
Params: the new icon
@ -1081,13 +1089,7 @@ end;
------------------------------------------------------------------------------}
procedure TApplication.DoBeforeMouseMessage(CurMouseControl: TControl);
begin
if (FMouseControl<>CurMouseControl) then begin
if (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
FMouseControl := CurMouseControl;
if (FMouseControl<>nil) then
FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
end;
UpdateMouseControl(GetControlAtMouse);
end;
{------------------------------------------------------------------------------
@ -1161,6 +1163,9 @@ end;
{ =============================================================================
$Log$
Revision 1.74 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.73 2004/02/23 08:19:04 micha
revert intf split

33
lcl/include/buttons.inc
View File

@ -103,36 +103,6 @@ Begin
inherited Click;
end;
{------------------------------------------------------------------------------
Method: TButton.CMMouseEnter
Params: None
Returns: Nothing
Handles the event when the button is entered
------------------------------------------------------------------------------}
procedure TButton.CMMouseEnter(var Message: TLMessage);
begin
Assert(False,'Trace:[TButton.CMMouseEnter]');
inherited CMMouseEnter(Message);
If assigned(FOnMouseEnter) then
FOnMouseEnter(Self);
end;
{------------------------------------------------------------------------------
Method: TButton.CMMouseLeave
Params: None
Returns: Nothing
Handles the event when the mouse leaves the button
------------------------------------------------------------------------------}
procedure TButton.CMMouseLeave(var Message: TLMessage);
begin
Assert(False,'Trace:[TButton.CMMouseLeave]');
inherited CMMouseLeave(Message);
If assigned(FOnMouseLeave) then
FOnMouseLeave(Self);
end;
{------------------------------------------------------------------------------
Method: TButton.CMDefaultClicked
Params: None
@ -173,6 +143,9 @@ end;
{ =============================================================================
$Log$
Revision 1.20 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.19 2004/02/23 08:19:04 micha
revert intf split

95
lcl/include/control.inc
View File

@ -569,6 +569,7 @@ end;
Procedure TControl.LMCaptureChanged(Var Message: TLMessage);
Begin
//Writeln('[LMCaptureChanged for '+Name+':'+Classname+']');
CaptureChanged;
End;
{------------------------------------------------------------------------------}
@ -590,12 +591,12 @@ end;
{------------------------------------------------------------------------------
TControl.CMMouseEnter
------------------------------------------------------------------------------}
Procedure TControl.CMMouseEnter(var Message :TLMessage);
Procedure TControl.CMMouseEnter(var Message: TLMessage);
Begin
// this is a LCL based mouse message, so don't call DoBeforeMouseMessage
if not FMouseEntered then begin
if (Message.LParam=0) and (not FMouseEntered) then begin
FMouseEntered:=true;
if Assigned(OnMouseEnter) then OnMouseEnter(Self);
MouseEnter;
if FParent <> nil then
FParent.Perform(CM_MOUSEENTER, 0, LParam(Self));
end;
@ -604,12 +605,12 @@ end;
{------------------------------------------------------------------------------
TControl.CMMouseLeave
------------------------------------------------------------------------------}
Procedure TControl.CMMouseLeave(var Message :TLMessage);
Procedure TControl.CMMouseLeave(var Message: TLMessage);
Begin
// this is a LCL based mouse message, so don't call DoBeforeMouseMessage
if FMouseEntered then begin
if (Message.LParam=0) and FMouseEntered then begin
FMouseEntered:=false;
if Assigned(OnMouseLeave) then OnMouseLeave(Self);
MouseLeave;
if FParent <> nil then
FParent.Perform(CM_MOUSELEAVE, 0, LParam(Self));
end;
@ -1408,11 +1409,13 @@ end;
------------------------------------------------------------------------------}
procedure TControl.WMLButtonDown(var Message: TLMLButtonDown);
begin
{$IFDEF VerboseMouseBugfix}
Writeln('TCONTROL WMLBUTTONDOWN A ',Name,':',ClassName);
{$ENDIF}
DoBeforeMouseMessage;
if csCaptureMouse in ControlStyle then MouseCapture := True;
if csCaptureMouse in ControlStyle then begin
{$IFDEF VerboseMouseCapture}
writeln('TControl.WMLButtonDown ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then Include(FControlState, csClicked);
DoMouseDown(Message, mbLeft, []);
//Writeln('TCONTROL WMLBUTTONDOWN B ',Name,':',ClassName);
@ -1455,7 +1458,12 @@ procedure TControl.WMLButtonDblClk(var Message: TLMLButtonDblClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if csCaptureMouse in ControlStyle then MouseCapture := True;
if csCaptureMouse in ControlStyle then begin
{$IFDEF VerboseMouseCapture}
writeln('TControl.WMLButtonDblClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
// first send a mouse down
DoMouseDown(Message, mbLeft ,[ssDouble]);
// then send the double click
@ -1499,7 +1507,12 @@ procedure TControl.WMLButtonTripleClk(var Message: TLMLButtonTripleClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if csCaptureMouse in ControlStyle then MouseCapture := True;
if csCaptureMouse in ControlStyle then begin
{$IFDEF VerboseMouseCapture}
writeln('TControl.WMLButtonTripleClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then TripleClick;
DoMouseDown(Message, mbLeft ,[ssTriple]);
end;
@ -1541,7 +1554,12 @@ procedure TControl.WMLButtonQuadClk(var Message: TLMLButtonQuadClk);
begin
DoBeforeMouseMessage;
//TODO: SendCancelMode(self);
if csCaptureMouse in ControlStyle then MouseCapture := True;
if csCaptureMouse in ControlStyle then begin
{$IFDEF VerboseMouseCapture}
writeln('TControl.WMLButtonQuadClk ',Name,':',ClassName);
{$ENDIF}
MouseCapture := True;
end;
if csClickEvents in ControlStyle then QuadClick;
DoMouseDown(Message, mbLeft ,[ssQuad]);
end;
@ -1583,8 +1601,12 @@ procedure TControl.WMLButtonUp(var Message: TLMLButtonUp);
begin
DoBeforeMouseMessage;
//Writeln('TControl.WMLButtonUp A ',Name,':',ClassName,' csCaptureMouse=',csCaptureMouse in ControlStyle,' csClicked=',csClicked in ControlState);
if csCaptureMouse in ControlStyle then
if csCaptureMouse in ControlStyle then begin
{$IFDEF VerboseMouseCapture}
writeln('TControl.WMLButtonUp ',Name,':',ClassName);
{$ENDIF}
MouseCapture := False;
end;
if csClicked in ControlState then
begin
@ -2344,31 +2366,47 @@ begin
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X,Y);
end;
{------------------------------------------------------------------------------}
{ TControl MouseMove
}
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TControl MouseMove
------------------------------------------------------------------------------}
Procedure TControl.MouseMove(Shift:TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseMove) then FOnMouseMove(Self, Shift, X,Y);
end;
{------------------------------------------------------------------------------}
{ TControl MouseUp
}
{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------
TControl MouseUp
------------------------------------------------------------------------------}
Procedure TControl.MouseUp(Button: TMouseButton; Shift:TShiftState;
X, Y: Integer);
begin
if Assigned(FOnMouseUp) then FOnMouseUp(Self, Button, Shift, X,Y);
end;
{------------------------------------------------------------------------------}
{ TControl SetShowHint
}
{------------------------------------------------------------------------------}
procedure TControl.MouseEnter;
begin
if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;
procedure TControl.MouseLeave;
begin
if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);
end;
{------------------------------------------------------------------------------
procedure TControl.CaptureChanged;
------------------------------------------------------------------------------}
procedure TControl.CaptureChanged;
begin
// anything to do here?
end;
{------------------------------------------------------------------------------
TControl SetShowHint
------------------------------------------------------------------------------}
procedure TControl.SetShowHint(Value : Boolean);
begin
if FShowHint <> Value then
@ -2798,6 +2836,9 @@ end;
{ =============================================================================
$Log$
Revision 1.174 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.173 2004/02/23 08:19:04 micha
revert intf split

2
lcl/include/custompage.inc
View File

@ -24,7 +24,7 @@ begin
fImageIndex:=-1;
fCompStyle := csPage;
ControlStyle := ControlStyle + [csAcceptsControls];
ControlStyle := ControlStyle + [csAcceptsControls,csDesignFixedBounds];
// set the default height and width
if (Owner<>nil) and (Owner is TControl) then begin

5
lcl/include/graphiccontrol.inc
View File

@ -41,8 +41,6 @@ end;
------------------------------------------------------------------------------}
destructor TGraphicControl.Destroy;
begin
{ if CaptureControl = Self then
SetCaptureControl(nil); }
FCanvas.Free;
inherited Destroy;
end;
@ -91,6 +89,9 @@ end;
{ =============================================================================
$Log$
Revision 1.8 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.7 2003/06/13 21:08:53 mattias
moved TColorButton to dialogs.pp

1
lcl/include/mouse.inc
View File

@ -42,6 +42,7 @@ Begin
{$ENDIF}
FCapture := Value;
if Value = 0 then ReleaseCapture else LCLIntf.SetCapture(Value);
FCapture := GetCapture;
end;
Procedure TMouse.SetCursorPos(Value : Tpoint);

4
lcl/include/popupmenu.inc
View File

@ -50,6 +50,7 @@ Procedure TPopupMenu.PopUp(X,Y : Integer);
begin
if ActivePopupMenu<>nil then ActivePopupMenu.Close;
FPopupPoint := Point(X, Y);
ReleaseCapture;
DoPopup(Self);
if Items.Count=0 then exit;
ActivePopupMenu:=Self;
@ -74,6 +75,9 @@ end;
{
$Log$
Revision 1.9 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.8 2003/05/12 13:40:50 mattias
fixed clsing popupmenu on showmodal

19
lcl/include/speedbutton.inc
View File

@ -686,14 +686,14 @@ Begin
end;
{------------------------------------------------------------------------------
Method: TSpeedButton.CMMouseEnter
Params: Message:
Method: TSpeedButton.MouseEnter
Params:
Returns: nothing
------------------------------------------------------------------------------}
procedure TSpeedButton.CMMouseEnter(var Message :TLMessage);
procedure TSpeedButton.MouseEnter;
begin
inherited CMMouseEnter(Message);
inherited MouseEnter;
if csDesigning in ComponentState then exit;
if not FMouseInControl
@ -705,14 +705,14 @@ begin
end;
{------------------------------------------------------------------------------
Method: TSpeedButton.CMMouseLeave
Params: Message:
Method: TSpeedButton.MouseLeave
Params:
Returns: nothing
------------------------------------------------------------------------------}
procedure TSpeedButton.CMMouseLeave(var Message :TLMessage);
procedure TSpeedButton.MouseLeave;
begin
inherited CMMouseLeave(Message);
inherited MouseLeave;
if csDesigning in ComponentState then exit;
if FMouseInControl
@ -773,6 +773,9 @@ end;
{ =============================================================================
$Log$
Revision 1.49 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.48 2004/02/11 11:34:15 mattias
started new TToolBar

229
lcl/include/toolbar.inc
View File

@ -20,6 +20,29 @@
{$IFDEF NewToolBar}
function CompareToolBarControl(Control1, Control2: TControl): integer;
var
ToolBar: TToolBar;
Row1: Integer;
Row2: Integer;
BtnHeight: Integer;
begin
Result:=0;
if not (Control1.Parent is TToolBar) then exit;
ToolBar:=TToolBar(Control1.Parent);
BtnHeight:=ToolBar.FRealizedButtonHeight;
Row1:=(Control1.Top+(BtnHeight div 2)) div ToolBar.FRealizedButtonHeight;
Row2:=(Control2.Top+(BtnHeight div 2)) div ToolBar.FRealizedButtonHeight;
if Row1<Row2 then
Result:=-1
else if Row1>Row2 then
Result:=1
else if Control1.Left<Control2.Left then
Result:=-1
else if Control1.Left>Control2.Left then
Result:=1;
end;
{------------------------------------------------------------------------------
Method: TToolbar.Create
Params: AOwner: the owner of the class
@ -48,7 +71,7 @@ begin
FHotImageChangeLink := TChangeLink.Create;
FHotImageChangeLink.OnChange := @HotImageListChange;
EdgeBorders := [ebTop];
SetInitialBounds(1,1,150,32);
SetInitialBounds(0,0,150,26);
Align := alTop;
end;
@ -135,10 +158,6 @@ procedure TToolBar.ControlsAligned;
var
NewWidth, NewHeight: integer;
begin
if FUpdateCount>0 then begin
UpdateVisibleBar;
exit;
end;
if tbfPlacingControls in FToolBarFlags then exit;
Include(FToolBarFlags,tbfPlacingControls);
try
@ -160,48 +179,13 @@ begin
end;
procedure TToolBar.SetButtonHeight(const AValue: Integer);
var
i: Integer;
begin
if AValue = FButtonHeight then exit;
FButtonHeight := AValue;
if ([csLoading,csDestroying]*ComponentState<>[]) or (FUpdateCount > 0) then
Exit;
// set all childs to buttonheight
BeginUpdate;
try
for i:=ControlCount-1 downto 0 do Controls[i].Height:=FButtonHeight;
finally
EndUpdate;
end;
SetButtonSize(ButtonWidth,AValue);
end;
procedure TToolBar.SetButtonWidth(const AValue: Integer);
var
i: Integer;
CurControl: TControl;
CurButton: TToolButton;
begin
if AValue = FButtonWidth then exit;
FButtonWidth := AValue;
if ([csLoading,csDestroying]*ComponentState<>[]) or (FUpdateCount > 0) then
Exit;
// set all toolbuttons to buttonwidth
BeginUpdate;
try
for i:=ControlCount-1 downto 0 do begin
CurControl:=Controls[i];
if (CurControl is TToolButton) then begin
CurButton:=TToolButton(CurControl);
case CurButton.Style of
tbsButton,tbsCheck,tbsDropDown:
CurButton.Width:=FButtonWidth;
end;
end;
end;
finally
EndUpdate;
end;
SetButtonSize(AValue,ButtonHeight);
end;
procedure TToolBar.ToolButtonDown(AButton: TToolButton; NewDown: Boolean);
@ -396,6 +380,52 @@ begin
end;
end;
procedure TToolBar.Paint;
begin
if csDesigning in ComponentState then begin
Canvas.Pen.Color:=clRed;
Canvas.FrameRect(Clientrect);
end;
inherited Paint;
end;
procedure TToolBar.SetButtonSize(NewButtonWidth, NewButtonHeight: integer);
var
CurControl: TControl;
NewWidth: Integer;
NewHeight: Integer;
i: Integer;
CurButton: TToolButton;
begin
if (FButtonWidth=NewButtonWidth) and (FButtonHeight=NewButtonHeight) then
exit;
FButtonWidth:=NewButtonWidth;
FButtonHeight:=NewButtonHeight;
if ([csLoading,csDestroying]*ComponentState<>[]) or (FUpdateCount > 0) then
Exit;
// set all childs to ButtonWidth ButtonHeight
BeginUpdate;
try
for i:=ControlCount-1 downto 0 do begin
CurControl:=Controls[i];
if CurControl.Align<>alNone then continue;
NewWidth:=CurControl.Width;
NewHeight:=FButtonHeight;
if (CurControl is TToolButton) then begin
CurButton:=TToolButton(CurControl);
case CurButton.Style of
tbsButton,tbsCheck,tbsDropDown:
NewWidth:=FButtonWidth;
end;
end;
CurControl.SetBounds(CurControl.Left,CurControl.Top,
NewWidth,NewHeight);
end;
finally
EndUpdate;
end;
end;
function TToolBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := WrapButtons(NewWidth, NewHeight);
@ -411,14 +441,6 @@ end;
If Wrapable=false, then the row is wrapped after the first button with
Wrap=true.
Wrapable
Indent
EdgeInner
EdgeOuter
EdgeBorders
BorderWidth
Button.Wrap
------------------------------------------------------------------------------}
function TToolBar.WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
var
@ -426,36 +448,106 @@ var
ARect: TRect;
x: Integer;
y: Integer;
NewControlWidth: Integer;
CurControl: TControl;
AlignedControls: TList;
StartX: Integer;
OrderedControls: TList;
procedure CalculatePosition;
var
AlignedControl: TControl;
NewBounds: TRect;
CurBounds: TRect;
j: Integer;
begin
if (CurControl is TToolButton)
and (TToolButton(CurControl).Style in [tbsButton,tbsDropDown,tbsCheck])
then
NewControlWidth:=ButtonWidth
else
NewControlWidth:=CurControl.Width;
NewBounds:=Bounds(x,y,NewControlWidth,ButtonHeight);
repeat
// move control to the right, until it does not overlap
for j:=0 to AlignedControls.Count-1 do begin
AlignedControl:=TControl(AlignedControls[j]);
CurBounds:=Bounds(AlignedControl.Left,AlignedControl.Top,
AlignedControl.Width,AlignedControl.Height);
if (CurBounds.Right>NewBounds.Left)
and (CurBounds.Left<NewBounds.Right)
and (CurBounds.Bottom>NewBounds.Top)
and (CurBounds.Top<NewBounds.Bottom) then begin
//writeln('CalculatePosition Move ',NewBounds.Left,'->',CurBounds.Right);
NewBounds.Left:=CurBounds.Right;
NewBounds.Right:=NewBounds.Left+NewControlWidth;
end;
end;
if (not Wrapable) or (NewBounds.Right<=ARect.Right)
or (NewBounds.Left=StartX) then begin
// control fits into the row
x:=NewBounds.Left;
y:=NewBounds.Top;
exit;
end;
// try next row
NewBounds.Left:=StartX;
NewBounds.Right:=NewBounds.Left+NewControlWidth;
inc(NewBounds.Top,ButtonHeight);
inc(NewBounds.Bottom,ButtonHeight);
//writeln('CalculatePosition Next Row ',NewBounds.Left,',',NewBounds.Top);
until false;
end;
begin
//writeln('WrapButtons ');
Result:=true;
BeginUpdate;
NewWidth:=0;
NewHeight:=0;
BeginUpdate;
AlignedControls:=TList.Create;
OrderedControls:=TList.Create;
try
for i:=0 to ControlCount-1 do begin
CurControl:=Controls[i];
if CurControl.Align<>alNone then
AlignedControls.Add(CurControl);
ARect:=ClientRect;
AdjustClientRect(ARect);
x:=ARect.Left+Indent;
y:=ARect.Top;
i:=0;
while i<ControlCount do begin
CurControl:=Controls[i];
if CurControl.Align=alNone then begin
// wrap
CurControl.SetBounds(x,y,CurControl.Width,CurControl.Height);
inc(x,CurControl.Width);
end;
inc(i);
end;
if CurControl.Align=alNone then
OrderedControls.Add(CurControl)
else
AlignedControls.Add(CurControl)
end;
// sort OrderedControls
if FRealizedButtonHeight=0 then FRealizedButtonHeight:=FButtonHeight;
OrderedControls.Sort(@CompareToolBarControl);
// position OrderedControls
ARect:=ClientRect;
AdjustClientRect(ARect);
StartX:=ARect.Left+Indent;
x:=StartX;
y:=ARect.Top;
NewControlWidth:=ButtonWidth;
i:=0;
while i<OrderedControls.Count do begin
CurControl:=TControl(OrderedControls[i]);
if CurControl.Align=alNone then begin
CalculatePosition;
//writeln('WrapButtons ',CurControl.Name,':',CurControl.ClassName,' ',x,',',y,',',CurControl.Width,',',CurControl.Height);
CurControl.SetBounds(x,y,NewControlWidth,ButtonHeight);
inc(x,CurControl.Width);
if (not Wrapable) and (CurControl is TToolButton)
and (TToolButton(CurControl).Wrap) then begin
// user forced wrap -> start new line
x:=StartX;
inc(y,ButtonHeight);
end;
end;
inc(i);
end;
FRealizedButtonHeight:=FButtonHeight;
finally
AlignedControls.Free;
OrderedControls.Free;
EndUpdate;
end;
end;
@ -2001,6 +2093,9 @@ end;
{ =============================================================================
$Log$
Revision 1.24 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.23 2004/02/23 08:19:04 micha
revert intf split

120
lcl/include/toolbutton.inc
View File

@ -1,3 +1,5 @@
// included by comctrls.pp
{ TToolButton
*****************************************************************************
@ -55,23 +57,29 @@ begin
fCompStyle := csToolButton;
FImageIndex := -1;
FStyle := tbsButton;
ControlStyle := [csCaptureMouse, csSetCaption];
ControlStyle := [csCaptureMouse, csSetCaption, csDesignNoSmoothResize];
SetInitialBounds(0,0,23,22);
end;
procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
writeln('TToolButton.MouseDown ',Name,':',ClassName,' ',ord(Button),' ',X,',',Y);
SetMouseInControl(true);
//writeln('TToolButton.MouseDown ',Name,':',ClassName,' ',ord(Button),' ',X,',',Y);
SetMouseInControl((X>=0) and (X<ClientWidth) and (Y>=0) and (Y<ClientHeight));
if (Button=mbLeft) and (not (tbfPressed in FToolButtonFlags)) then begin
Include(FToolButtonFlags,tbfPressed);
Invalidate;
end;
if (Style=tbsDropDown) and (Button=mbLeft) and Enabled then
// switch
Down := not Down;
inherited MouseDown(Button,Shift,X,Y);
if (Style=tbsDropDown) and (Button=mbLeft) and Enabled then begin
if (FToolBar<>nil) and (X>ClientWidth-FToolBar.FDropDownWidth) then begin
end else begin
Down := true;
end;
end;
end;
procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
@ -79,26 +87,35 @@ begin
//writeln('TToolButton.MouseMove ',Name,':',ClassName,' ',X,',',Y);
SetMouseInControl((X>=0) and (X<ClientWidth) and (Y>=0) and (Y<ClientHeight));
inherited MouseMove(Shift, X, Y);
if (Style=tbsDropDown) and MouseCapture then
// while dragging: down when mouse in, and up, when mouse out of control
Down := FMouseInControl;
end;
procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
writeln('TToolButton.MouseUp ',Name,':',ClassName,' ',ord(Button),' ',X,',',Y);
//writeln('TToolButton.MouseUp ',Name,':',ClassName,' ',ord(Button),' ',X,',',Y);
if (Button=mbLeft) and (tbfPressed in FToolButtonFlags) then begin
Exclude(FToolButtonFlags,tbfPressed);
Invalidate;
end;
SetMouseInControl(true);
SetMouseInControl((X>=0) and (X<ClientWidth) and (Y>=0) and (Y<ClientHeight));
inherited MouseUp(Button, Shift, X, Y);
if (Button=mbLeft) and FMouseInControl then begin
writeln('TToolButton.MouseUp ',Name,':',ClassName,' ',Style=tbsCheck);
if Style=tbsDropDown then Down:=False;
if Style=tbsCheck then Down:=not Down;
Click;
if (Button=mbLeft) then begin
//writeln('TToolButton.MouseUp ',Name,':',ClassName,' ',Style=tbsCheck);
if (Style=tbsButton) then Down:=false;
if (Style=tbsDropDown) then begin
if (FToolBar<>nil) and FMouseInControl
and (X>ClientWidth-FToolBar.FDropDownWidth) then begin
CheckMenuDropdown;
end;
Down:=false;
end;
if FMouseInControl then begin
if (Style=tbsCheck) then Down:=not Down;
Click;
end;
end;
Invalidate;
end;
@ -148,7 +165,7 @@ var
ImgList: TCustomImageList;
ImgIndex: integer;
begin
writeln('TToolButton.Paint A ',Name,' FToolBar=',HexStr(Cardinal(FToolBar),8),' ',ClientWidth,',',ClientHeight,' ',ord(Style));
//writeln('TToolButton.Paint A ',Name,' FToolBar=',HexStr(Cardinal(FToolBar),8),' ',ClientWidth,',',ClientHeight,' ',ord(Style));
if (FToolBar<>nil) and (ClientWidth>0) and (ClientHeight>0) then begin
PaintRect:=ClientRect; // the whole paint area
@ -186,9 +203,9 @@ begin
if IconSize.X>0 then begin
if FToolBar.List then begin
// icon left of text
IconPos.X:=(ButtonRect.Left+ButtonRect.Right-IconSize.x-TextSize.cy-2) div 2;
IconPos.X:=(ButtonRect.Left+ButtonRect.Right-IconSize.x-TextSize.cx-2) div 2;
IconPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-IconSize.y) div 2;
TextPos.X:=IconPos.X+2;
TextPos.X:=IconPos.X+IconSize.X+2;
TextPos.Y:=(ButtonRect.Top+ButtonRect.Bottom-TextSize.cy) div 2;
end else begin
// icon above text
@ -237,13 +254,15 @@ begin
and (csDesigning in ComponentState) then begin
Canvas.Brush.Color:=clBackground;
Canvas.Pen.Color:=clBlack;
dec(PaintRect.Right);
dec(PaintRect.Bottom);
Canvas.FrameRect(PaintRect);
end;
// draw divider
if (Style in [tbsDivider]) then begin
DividerRect.Left:=((ButtonRect.Left+ButtonRect.Right) div 2)-2;
DividerRect.Right:=DividerRect.Left+4;
DividerRect.Left:=((ButtonRect.Left+ButtonRect.Right) div 2)-1;
DividerRect.Right:=DividerRect.Left+2;
DividerRect.Top:=2;
DividerRect.Bottom:=Max(DividerRect.Top,PaintRect.Bottom-2);
DrawEdge(Canvas.Handle,DividerRect,EDGE_ETCHED,BF_LEFT);
@ -293,14 +312,21 @@ begin
Message.Result := 0;
end;
procedure TToolButton.CMMouseEnter(var Message: TLMessage);
procedure TToolButton.MouseEnter;
begin
//writeln('TToolButton.MouseEnter ',Name);
inherited MouseEnter;
SetMouseInControl(true);
end;
procedure TToolButton.CMMouseLeave(var Message: TLMessage);
procedure TToolButton.MouseLeave;
begin
//writeln('TToolButton.MouseLeave ',Name);
inherited MouseLeave;
SetMouseInControl(false);
if (not MouseCapture) and (tbfPressed in FToolButtonFlags) then begin
Exclude(FToolButtonFlags,tbfPressed);
end;
end;
procedure TToolButton.SetDown(Value: Boolean);
@ -315,7 +341,7 @@ begin
exit;
end;
writeln('TToolButton.SetDown ',Style=tbsCheck,',',FDown,',',GroupAllUpAllowed);
//writeln('TToolButton.SetDown ',Style=tbsCheck,',',FDown,',',GroupAllUpAllowed);
if (Style=tbsCheck) and FDown and (not GroupAllUpAllowed) then
exit;
@ -339,8 +365,6 @@ begin
Invalidate;
if FToolBar <> nil then
FToolBar.ToolButtonDown(Self,FDown);
if (Style=tbsDropDown) and Down and Enabled then
CheckMenuDropdown;
end;
procedure TToolButton.SetDropdownMenu(Value: TPopupMenu);
@ -451,6 +475,8 @@ procedure TToolButton.SetMouseInControl(NewMouseInControl: Boolean);
begin
if FMouseInControl=NewMouseInControl then exit;
FMouseInControl:=NewMouseInControl;
if (Style in [tbsDropDown,tbsButton]) and (not FMouseInControl) then
Down:=false;
Invalidate;
end;
@ -580,7 +606,9 @@ end;
function TToolButton.GetButtonDrawFlags: integer;
begin
Result:=DFCS_BUTTONPUSH;
if FDown or (tbfPressed in FToolButtonFlags) then inc(Result,DFCS_PUSHED);
if FDown
or ((tbfPressed in FToolButtonFlags) and FMouseInControl) then
inc(Result,DFCS_PUSHED);
if not Enabled then inc(Result,DFCS_INACTIVE);
if (FToolBar<>nil) and FToolBar.Flat
@ -655,6 +683,40 @@ begin
end;
end;
procedure TToolButton.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
var
NewButtonWidth: Integer;
NewButtonHeight: Integer;
OldLeft: Integer;
OldTop: Integer;
OldWidth: Integer;
OldHeight: Integer;
begin
if ([csDesigning,csLoading,csDestroying]*ComponentState=[csDesigning])
and (FToolBar<>nil)
and (not (tbfPlacingControls in FToolBar.FToolBarFlags))
and (FToolBar.FUpdateCount=0)
and (AWidth>0) and (AHeight>0) then begin
if Style in [tbsButton,tbsDropDown,tbsCheck] then
NewButtonWidth:=AWidth
else
NewButtonWidth:=FToolBar.ButtonWidth;
NewButtonHeight:=AHeight;
//writeln('TToolButton.DoSetBounds NewButtonSize=',NewButtonWidth,',',NewButtonHeight);
OldLeft:=Left;
OldTop:=Top;
OldWidth:=Width;
OldHeight:=Height;
FToolBar.SetButtonSize(NewButtonWidth,NewButtonHeight);
if (OldLeft<>Left) or (OldTop<>Top)
or (OldWidth<>Width) or (OldHeight<>Height) then
// button was auto aligned -> ignore setbounds
exit;
end;
inherited DoSetBounds(ALeft, ATop, AWidth, AHeight);
end;
{$ELSE NewToolBar}
const
@ -1126,9 +1188,13 @@ end;
{$ENDIF}
// included by comctrls.pp
{
$Log$
Revision 1.14 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.13 2004/02/22 16:22:53 mattias
fixed old toolbar compilation

10
lcl/include/toolwindow.inc
View File

@ -42,7 +42,7 @@ begin
if ebRight in FEdgeBorders then
dec(ARect.Right,EdgeWidth);
if ebBottom in FEdgeBorders then
inc(ARect.Bottom,EdgeWidth);
dec(ARect.Bottom,EdgeWidth);
end;
procedure TToolWindow.SetEdgeBorders(Value: TEdgeBorders);
@ -79,13 +79,13 @@ var
begin
FEdgeBorderType := 0;
if (ebTOP in FEdgeBorders) then
FEdgeBorderType := FEdgeBorderType or longint(ebTOP);
FEdgeBorderType := FEdgeBorderType or longint(BF_TOP);
if (ebBottom in FEdgeBorders) then
FEdgeBorderType := FEdgeBorderType or longint(ebBottom);
FEdgeBorderType := FEdgeBorderType or longint(BF_BOTTOM);
if (ebLeft in FEdgeBorders) then
FEdgeBorderType := FEdgeBorderType or longint(ebLeft);
FEdgeBorderType := FEdgeBorderType or longint(BF_LEFT);
if (ebRight in FEdgeBorders) then
FEdgeBorderType := FEdgeBorderType or longint(ebRight);
FEdgeBorderType := FEdgeBorderType or longint(BF_RIGHT);
ARect:=ClientRect;
DrawEdge(Canvas.Handle,ARect,
InnerStyles[FEdgeInner] or OuterStyles[FEdgeOuter],FEdgeBorderType);

3
lcl/include/treeview.inc
View File

@ -4669,7 +4669,8 @@ begin
inherited MouseUp(Button, Shift, X, Y);
if (Button = mbRight) and (Shift = [ssRight]) and Assigned(PopupMenu) then
exit;
MouseCapture := False;
if Button=mbLeft then
MouseCapture := False;
Exclude(fStates, tvsWaitForDragging);
if (Button=mbLeft)
and (fStates * [tvsDblClicked, tvsTripleClicked, tvsQuadClicked,

13
lcl/include/wincontrol.inc
View File

@ -490,16 +490,14 @@ begin
try
//if csDesigning in ComponentState then begin
//writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' AlignWork=',AlignWork);
//writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' AlignWork=',AlignWork,' ControlCount=',ControlCount);
//if AControl<>nil then writeln(' AControl=',AControl.Name,':',AControl.ClassName);
//end;
if AlignWork then
begin
AdjustClientRect(ARect);
FAdjustClientRectRealized:=ARect;
{$IFDEF VerboseClientRectBugFix}
writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' ClientRect=',Rect.Left,',',Rect.Top,',',Rect.Right,',',Rect.Bottom);
{$ENDIF}
//writeln('[TWinControl.AlignControls] ',Name,':',Classname,' ',Left,',',Top,',',Width,',',Height,' ClientRect=',ARect.Left,',',ARect.Top,',',ARect.Right,',',ARect.Bottom);
AlignList := TList.Create;
try
DoAlign(alTop);
@ -1311,7 +1309,7 @@ var
P : TPoint;
ClientBounds: TRect;
begin
if GetCapture = Handle
if FindOwnerControl(GetCapture) = Self
then begin
Control := nil;
if (CaptureControl <> nil)
@ -1792,7 +1790,7 @@ Begin
if Dragging then Exit;
LM_CANCELMODE:
if (GetCapture = Handle)
if (FindOwnerControl(GetCapture) = Self)
and (CaptureControl <> nil)
and (CaptureControl.Parent = Self)
then CaptureControl.Perform(LM_CANCELMODE,0,0);
@ -3388,6 +3386,9 @@ end;
{ =============================================================================
$Log$
Revision 1.207 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.206 2004/02/23 08:19:04 micha
revert intf split

36
lcl/interfaces/gtk/gtkcallback.inc
View File

@ -479,6 +479,8 @@ begin
end;
writeln('');
{$ENDIF}
UpdateMouseCaptureControl;
Mess.Msg := LM_ACTIVATE;
Status := DeliverPostMessage(Data, Mess);
@ -509,6 +511,8 @@ begin
else
writeln(' LCLObject=nil');
{$ENDIF}
UpdateMouseCaptureControl;
Mess.Msg := LM_DEACTIVATE;
Status := DeliverPostMessage(Data, Mess);
@ -850,6 +854,8 @@ begin
writeln('');
{$ENDIF}
UpdateMouseCaptureControl;
//TODO: fill in old focus
FillChar(Mess,SizeOf(Mess),0);
Mess.msg := LM_SETFOCUS;
@ -942,6 +948,9 @@ begin
end;
writeln('');
{$ENDIF}
UpdateMouseCaptureControl;
FillChar(Mess,SizeOf(Mess),0);
Mess.msg := LM_KILLFOCUS;
@ -1418,16 +1427,9 @@ begin
if DesignOnlySignal then exit;
if not ControlGetsMouseDownBefore(TControl(Data)) then exit;
// grabbing for TSplitter and our special widgets -> Maybe ths is the key for drag&drop
CaptureWidget:=PGtkWidget(TWinControl(Data).Handle);
if (GtkWidgetIsA(CaptureWidget,GTKAPIWidget_GetType))
or (TWinControl(Data) is TCustomSplitter)
or (TWinControl(Data) is TToolButton) then begin
CaptureWidget:=GetWidgetInfo(CaptureWidget,true)^.ImplementationWidget;
if not gtk_widget_has_focus(CaptureWidget) then
gtk_widget_grab_focus(CaptureWidget);
if Event^.button=1 then
gtk_grab_add(CaptureWidget);
if Event^.button=1 then begin
CaptureMouseForWidget(CaptureWidget,mctGTKIntf);
end;
end else begin
@ -1566,7 +1568,6 @@ function gtkMouseBtnRelease(widget: PGtkWidget; event : pgdkEventButton;
data: gPointer) : GBoolean; cdecl;
var
DesignOnlySignal: boolean;
CaptureWidget: PGtkWidget;
begin
Result := CallBackDefaultReturn;
@ -1588,19 +1589,9 @@ begin
if not (csDesigning in TComponent(Data).ComponentState) then begin
DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseRelease);
CaptureWidget:=PGtkWidget(TWinControl(Data).Handle);
if GtkWidgetIsA(CaptureWidget,GTKAPIWidget_GetType)
or (TWinControl(Data) is TCustomSplitter)
or (TWinControl(Data) is TToolButton)
then begin
CaptureWidget:=GetWidgetInfo(CaptureWidget,true)^.ImplementationWidget;
if Event^.button=1 then
gtk_grab_remove(CaptureWidget);
end;
ReleaseMouseCapture;
if DesignOnlySignal or (not ControlGetsMouseUpBefore(TControl(Data))) then
begin
ReleaseMouseCapture(false);
exit;
end;
end else begin
@ -3074,6 +3065,9 @@ end;
{ =============================================================================
$Log$
Revision 1.221 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.220 2004/02/22 15:39:44 mattias
fixed error handling on saving lpi file

10
lcl/interfaces/gtk/gtkglobals.pp
View File

@ -36,6 +36,13 @@ var
UpdatingTransientWindows: boolean;
// mouse --------------------------------------------------------------------
type
TMouseCaptureType = (
mctGTK, // gtk is handling capturing
mctGTKIntf, // gtk interface has captured the mouse
mctLCL // a LCL control has captured the mouse
);
var
//drag icons
//TrashCan_Open : PgdkPixmap;
@ -48,7 +55,8 @@ var
//Dragging : Boolean;
MouseCaptureWidget: PGtkWidget;
MouseCapureByLCL: boolean;
MouseCaptureType: TMouseCaptureType;
MouseCaptureIndex: cardinal;
const
DblClickTime = 250;// 250 miliseconds or less between clicks is a double click

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

@ -344,7 +344,7 @@ begin
gtk_handler_quark := g_quark_from_static_string('gtk-signal-handlers');
MouseCaptureWidget := nil;
MouseCapureByLCL := false;
MouseCaptureType := mctGTK;
LastLeft:=EmptyLastMouseClick;
LastMiddle:=EmptyLastMouseClick;
@ -423,6 +423,9 @@ end.
{ =============================================================================
$Log$
Revision 1.169 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.168 2004/02/21 15:37:33 mattias
moved compiler options to project menu, added -CX for smartlinking

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

@ -430,6 +430,8 @@ procedure TgtkObject.ShowModal(Sender: TObject);
var
GtkWindow: PGtkWindow;
begin
ReleaseMouseCapture;
if Sender is TCommonDialog then
begin
GtkWindow:=PGtkWindow(TCommonDialog(Sender).Handle);
@ -1128,7 +1130,7 @@ begin
if GtkWidgetIsA(Widget,gtk_toolbar_get_type) then begin
FixedWidget:=GetFixedWidget(Widget);
if (FixedWidget<>nil) and (FixedWidget<>Widget) then begin
writeln('WARNING: ToDo TgtkObject.RealizeWidgetSize ',NewWidth,',',NewHeight);
//writeln('WARNING: ToDo TgtkObject.RealizeWidgetSize for TToolBar ',NewWidth,',',NewHeight);
gtk_widget_set_usize(FixedWidget,NewWidth,NewHeight);
end;
end;
@ -3265,6 +3267,7 @@ begin
LM_POPUPSHOW :
Begin
ReleaseMouseCapture;
gtk_menu_popup(PgtkMenu(TPopupMenu(Sender).Handle),
nil,
nil,
@ -6261,7 +6264,6 @@ begin
SetMainWidget(Result,ClientWidget);
gtk_toolbar_set_space_size(PGTKToolbar(Result),0);
gtk_toolbar_set_space_style(PGTKToolbar(Result),GTK_TOOLBAR_SPACE_EMPTY);
writeln('TgtkObject.CreateToolBar ',PGTKToolbar(Result)^.button_maxw,',',PGTKToolbar(Result)^.button_maxh);
{$ENDIF}
gtk_widget_show(Result);
end;
@ -6909,6 +6911,11 @@ begin
gdk_window_set_functions(AWindow, func);
end;
ShareWindowAccelGroups(SenderWidget);
// capturing is always gtkwindow dependent. On showing a new window
// the gtk will put a new widget on the grab stack.
// -> release our capture
ReleaseMouseCapture;
end;
gtk_widget_show(SenderWidget);
@ -9225,6 +9232,9 @@ end;
{ =============================================================================
$Log$
Revision 1.472 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.471 2004/02/22 10:43:20 mattias
added child-parent checks

121
lcl/interfaces/gtk/gtkproc.inc
View File

@ -3104,35 +3104,119 @@ begin
CurMouseCaptureWidget:=gtk_grab_get_current;
if OldMouseCaptureWidget<>CurMouseCaptureWidget then begin
// the mouse grab changed
// -> this means the gtk itself has changed the mouse grab
{$IFDEF VerboseMouseCapture}
writeln('UpdateMouseCaptureControl Capture changed from ',
'[',GetWidgetDebugReport(OldMouseCaptureWidget),']',
' to [',GetWidgetDebugReport(CurMouseCaptureWidget),']');
{$ENDIF}
// notify the new capture control
MouseCaptureWidget:=CurMouseCaptureWidget;
MouseCapureByLCL:=false;
if MouseCaptureWidget<>nil then
MouseCaptureType:=mctGTK;
if MouseCaptureWidget<>nil then begin
// the MouseCaptureWidget is probably not a main widget
SendMessage(HWnd(MouseCaptureWidget), LM_CAPTURECHANGED, 0,
HWnd(OldMouseCaptureWidget));
end;
end;
end;
procedure IncreaseMouseCaptureIndex;
begin
if MouseCaptureIndex<$ffffffff then
inc(MouseCaptureIndex)
else
MouseCaptureIndex:=0;
end;
procedure CaptureMouseForWidget(Widget: PGtkWidget; Owner: TMouseCaptureType);
var
CaptureWidget: PGtkWidget;
NowIndex: Cardinal;
begin
{$IFDEF VerboseMouseCapture}
writeln('CaptureMouseForWidget START ',GetWidgetDebugReport(Widget));
{$ENDIF}
if not (Owner in [mctGTKIntf,mctLCL]) then exit;
// not every widget can capture the mouse
CaptureWidget:=GetDefaultMouseCaptureWidget(Widget);
if CaptureWidget=nil then exit;
UpdateMouseCaptureControl;
if (MouseCaptureType<>mctGTK) then begin
// we are capturing
if (MouseCaptureWidget=CaptureWidget) then begin
// we are already capturing this widget
exit;
end;
// release old capture
ReleaseMouseCapture;
end;
{$IFDEF VerboseMouseCapture}
writeln('CaptureMouseForWidget Start Capturing for ',GetWidgetDebugReport(CaptureWidget));
{$ENDIF}
IncreaseMouseCaptureIndex;
NowIndex:=MouseCaptureIndex;
if not gtk_widget_has_focus(CaptureWidget) then
gtk_widget_grab_focus(CaptureWidget);
if NowIndex=MouseCaptureIndex then begin
{$IFDEF VerboseMouseCapture}
writeln('CaptureMouseForWidget Commit Capturing for ',GetWidgetDebugReport(CaptureWidget));
{$ENDIF}
MouseCaptureWidget:=CaptureWidget;
MouseCaptureType:=Owner;
gtk_grab_add(CaptureWidget);
end;
end;
function GetDefaultMouseCaptureWidget(Widget: PGtkWidget
): PGtkWidget;
var
WidgetInfo: PWinWidgetInfo;
LCLObject: TObject;
begin
Result:=nil;
if Widget=nil then exit;
if GtkWidgetIsA(Widget,GTKAPIWidget_GetType) then begin
WidgetInfo:=GetWidgetInfo(Widget,false);
if WidgetInfo<>nil then
Result:=WidgetInfo^.ImplementationWidget;
exit;
end;
LCLObject:=GetNearestLCLObject(Widget);
if LCLObject=nil then exit;
if ((TWinControl(LCLObject) is TCustomSplitter)
or (TWinControl(LCLObject) is TToolButton))
and (TWinControl(LCLObject).HandleAllocated)
then begin
WidgetInfo:=GetWidgetInfo(PGtkWidget(TWinControl(LCLObject).Handle),false);
if WidgetInfo<>nil then
Result:=WidgetInfo^.ImplementationWidget;
end;
end;
{------------------------------------------------------------------------------
procedure ReleaseLCLMouseCapture;
procedure ReleaseMouseCapture;
If the current mouse capture was captured by the LCL, release the capture.
If the current mouse capture was captured by the LCL or the gtk intf, release
the capture. Don't release mouse captures of the gtk, because captures must
be balanced and this is already done by the gtk.
------------------------------------------------------------------------------}
procedure ReleaseMouseCapture(OnlyIfCapturedByLCL: boolean);
procedure ReleaseMouseCapture;
var
OldCaptureWidget: PGtkWidget;
OldMouseCaptureWidget: PGtkWidget;
begin
if OnlyIfCapturedByLCL and (not MouseCapureByLCL) then exit;
{$IfNDef ActivateMouseCapture}
exit;
{$EndIf}
repeat
OldCaptureWidget:=gtk_grab_get_current;
if OldCaptureWidget<>nil then
gtk_grab_remove(OldCaptureWidget)
else
break;
until false;
{$IFDEF VerboseMouseCapture}
writeln('ReleaseMouseCapture ',ord(MouseCaptureType),' MouseCaptureWidget=[',GetWidgetDebugReport(MouseCaptureWidget),']');
{$ENDIF}
if MouseCaptureType=mctGTK then exit;
OldMouseCaptureWidget:=MouseCaptureWidget;
MouseCaptureWidget:=nil;
MouseCaptureType:=mctGTK;
gtk_grab_remove(OldMouseCaptureWidget);
end;
{------------------------------------------------------------------------------
@ -6320,6 +6404,9 @@ end;
{ =============================================================================
$Log$
Revision 1.260 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.259 2004/02/13 15:49:54 mattias
started advanced LCL auto sizing

8
lcl/interfaces/gtk/gtkproc.pp
View File

@ -401,10 +401,14 @@ function GetWidgetOrigin(TheWidget: PGtkWidget): TPoint;
function GetWidgetClientOrigin(TheWidget: PGtkWidget): TPoint;
function TranslateGdkPointToClientArea(SourceWindow: PGdkWindow;
SourcePos: TPoint; DestinationWidget: PGtkWidget): TPoint;
procedure ReleaseMouseCapture(OnlyIfCapturedByLCL: boolean);
procedure UpdateMouseCaptureControl;
procedure SetCursor(AWinControl : TWinControl; Data: Pointer);
// mouse capturing
procedure CaptureMouseForWidget(Widget: PGtkWidget; Owner: TMouseCaptureType);
function GetDefaultMouseCaptureWidget(Widget: PGtkWidget): PGtkWidget;
procedure ReleaseMouseCapture;
procedure UpdateMouseCaptureControl;
{$IFNDEF GTK2_2}
// MWE:
// TODO: check if the new keyboard routines require X on GTK2

161
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -2415,8 +2415,33 @@ end;
Draws one or more edges of a rectangle. The rectangle is the area
Left to Right-1 and Top to Bottom-1.
------------------------------------------------------------------------------}
function TgtkObject.DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal;
function TgtkObject.DrawEdge(DC: HDC; var ARect: TRect; Edge: Cardinal;
grfFlags: Cardinal): Boolean;
procedure DrawEdges(var R: TRect; GC: pgdkGC; Drawable:PGdkDrawable;
const TopLeftColor, BottomRightColor: TGDKColor);
begin
gdk_gc_set_foreground(GC, @TopLeftColor);
if (grfFlags and BF_TOP) = BF_TOP then begin
gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Right, R.Top);
inc(R.Top);
end;
if (grfFlags and BF_LEFT) = BF_LEFT then begin
gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Left, R.Bottom);
inc(R.Left);
end;
gdk_gc_set_foreground(GC, @BottomRightColor);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM then begin
gdk_draw_line(Drawable, GC, R.Left, R.Bottom-1, R.Right, R.Bottom-1);
dec(R.Bottom);
end;
if (grfFlags and BF_RIGHT) = BF_RIGHT then begin
gdk_draw_line(Drawable, GC, R.Right-1, R.Top, R.Right-1, R.Bottom);
dec(R.Right);
end;
end;
Var
InnerTL, OuterTL,
InnerBR, OuterBR: TGDKColor;
@ -2425,7 +2450,7 @@ Var
R: TRect;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TgtkObject.DrawEdge] DC:0x%x, Rect = %d,%d,%d,%d', [DC, Rect.Left, Rect.Top,Rect.Right, Rect.Bottom]));
//writeln('TgtkObject.DrawEdge Edge=',HexStr(Cardinal(Edge),8),' grfFlags=',HexStr(Cardinal(grfFlags),8));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
@ -2436,90 +2461,50 @@ begin
Result := False;
end
else begin
R := Rect;
Dec(R.Right);
Dec(R.Bottom);
R := ARect;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
OffsetRect(R,DCOrigin.X,DCOrigin.Y);
// try to use the gdk functions, so that the current theme is used
BInner := False;
BOuter := False;
// TODO: changeThis to real colors
// TODO: change this to real colors
if (edge and BDR_RAISEDINNER) = BDR_RAISEDINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
// gdk_color_white(gdk_colormap_get_system, @InnerTL);
// gdk_color_black(gdk_colormap_get_system, @InnerBR);
BInner := True;
end;
if (edge and BDR_SUNKENINNER) = BDR_SUNKENINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
// gdk_color_black(gdk_colormap_get_system, @InnerTL);
// gdk_color_white(gdk_colormap_get_system, @InnerBR);
BInner := True;
end;
if (edge and BDR_RAISEDOUTER) = BDR_RAISEDOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNFACE));
OuterBR := AllocGDKColor(GetSysColor(COLOR_WINDOWFRAME));
// gdk_color_white(gdk_colormap_get_system, @OuterTL);
// gdk_color_black(gdk_colormap_get_system, @OuterBR);
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
BOuter := True;
end;
if (edge and BDR_SUNKENOUTER) = BDR_SUNKENOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_WINDOWFRAME));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNFACE));
// gdk_color_black(gdk_colormap_get_system, @OuterTL);
// gdk_color_white(gdk_colormap_get_system, @OuterBR);
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
BOuter := True;
end;
gdk_gc_set_fill(GC, GDK_SOLID);
SelectedColors := dcscCustom;
BeginGDKErrorTrap;
gdk_gc_set_fill(GC, GDK_SOLID);
// Draw outer rect
if Bouter
then with R do
begin
gdk_gc_set_foreground(GC, @OuterTL);
if (grfFlags and BF_TOP) = BF_TOP
then gdk_draw_line(Drawable, GC, Left, Top, Right, Top);
if (grfFlags and BF_LEFT) = BF_LEFT
then gdk_draw_line(Drawable, GC, Left, Top, Left, Bottom);
gdk_gc_set_foreground(GC, @OuterBR);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM
then gdk_draw_line(Drawable, GC, Left, Bottom, Right + 1, Bottom);
if (grfFlags and BF_RIGHT) = BF_RIGHT
then gdk_draw_line(Drawable, GC, Right, Top, Right, Bottom + 1);
InflateRect(R, -1, -1);
end;
if Bouter then
DrawEdges(R,GC,Drawable,OuterTL,OuterBR);
// Draw inner rect
if BInner
then with R do
begin
gdk_gc_set_foreground(GC, @InnerTL);
if (grfFlags and BF_TOP) = BF_TOP
then gdk_draw_line(Drawable, GC, Left, Top, Right, Top);
if (grfFlags and BF_LEFT) = BF_LEFT
then gdk_draw_line(Drawable, GC, Left, Top, Left, Bottom);
gdk_gc_set_foreground(GC, @InnerBR);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM
then gdk_draw_line(Drawable, GC, Left, Bottom, Right + 1, Bottom);
if (grfFlags and BF_RIGHT) = BF_RIGHT
then gdk_draw_line(Drawable, GC, Right, Top, Right, Bottom + 1);
InflateRect(R, -1, -1);
end;
if BInner then
DrawEdges(R,GC,Drawable,InnerTL,InnerBR);
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterTL, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterBR, 1);
@ -2533,26 +2518,23 @@ begin
Width := R.Right - R.Left + 1;
Height := R.Bottom - R.Top + 1;
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
If not CurrentBrush^.IsNullBrush then
if (CurrentBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(CurrentBrush^.GDIBrushColor.ColorRef))) then
and (IsBackgroundColor(TColor(CurrentBrush^.GDIBrushColor.ColorRef)))
then
StyleFillRectangle(Drawable, GC, CurrentBrush^.GDIBrushColor.ColorRef,
R.Left+DCOrigin.X, R.Top+DCOrigin.Y, Width, Height)
R.Left, R.Top, Width, Height)
else
gdk_draw_rectangle(Drawable, GC, 1, R.Left+DCOrigin.X, R.Top+DCOrigin.Y,
Width, Height);
gdk_draw_rectangle(Drawable, GC, 1, R.Left, R.Top, Width, Height);
end;
EndGDKErrorTrap;
// adjust rect if needed
if (grfFlags and BF_ADJUST) = BF_ADJUST
then Rect := R;
then ARect := R;
Result := True;
end;
end;
Assert(False, Format('trace:< [TgtkObject.DrawEdge] DC:0x%x, Rect = %d,%d,%d,%d', [DC, Rect.Left, Rect.Top,Rect.Right, Rect.Bottom]));
end;
{------------------------------------------------------------------------------
@ -7596,58 +7578,20 @@ end;
------------------------------------------------------------------------------}
function TgtkObject.SetCapture(Value: Longint): Longint;
{$IfDef VerboseMouseCapture}
var
Sender : TObject;
CurMouseCaptureHandle: PGtkWidget;
{$EndIf}
Widget: PGtkWidget;
begin
Assert(False, Format('Trace:> [TgtkObject.SetCapture] 0x%x', [Value]));
Widget:=PGtkWidget(Value);
{$IfDef VerboseMouseCapture}
if Value<>0 then
Sender:=GetLCLObject(Pointer(Value))
else
Sender:=nil;
write('TgtkObject.SetCapture New=',HexStr(Cardinal(Value),8),' ');
if Sender=nil then
writeln('Sender=nil')
else
writeln('Sender=',TControl(Sender).Name,':',Sender.ClassName);
CurMouseCaptureHandle:=gtk_grab_get_current;
writeln(' gtk=',HexStr(Cardinal(CurMouseCaptureHandle),8),
' MouseCaptureWidget=',HexStr(Cardinal(MouseCaptureWidget),8));
writeln('TgtkObject.SetCapture NewValue=[',GetWidgetDebugReport(Widget),']');
{$EndIf}
// return old capture handle
Result := GetCapture;
// check that the widget is a widget with a LCL control
if (Value<>0) and (GetLCLObject(Pointer(Value))=nil) then exit;
if Result<>Value then begin
// capture changes
// If the gtk-interface has grabbed the mouse, it is somewhere in the stack
// of grabs. The gtk uses a grab stack to handle parent-child chains of
// mouse events. But we stop this chain anyway, the LCL can set and release
// mouse captures at any time and X can freeze, when a grab is not realeased
// and the window is destroyed.
// -> remove all grabs
ReleaseMouseCapture(true);
// grab
if (Value<>0) then begin
{$IfDef ActivateMouseCapture}
gtk_grab_add(PgtkWidget(Value));
{$EndIf}
end;
{$IfDef VerboseMouseCapture}
writeln('TgtkObject.SetCapture RESULT: gtk=',HexStr(Cardinal(gtk_grab_get_current),8));
{$EndIf}
end;
UpdateMouseCaptureControl;
// capture
CaptureMouseForWidget(Widget,mctLCL);
end;
{------------------------------------------------------------------------------
@ -8745,6 +8689,9 @@ end;
{ =============================================================================
$Log$
Revision 1.333 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.332 2004/02/21 01:01:03 mattias
added uninstall popupmenuitem to package graph explorer

5
lcl/interfaces/gtk/gtkwinapih.inc
View File

@ -66,7 +66,7 @@ function DeleteDC(hDC: HDC): Boolean; override;
function DeleteObject(GDIObject: HGDIOBJ): Boolean; override;
function DestroyCaret(Handle : HWND): Boolean; override;
Function DrawFrameControl(DC: HDC; var Rect : TRect; uType, uState : Cardinal) : Boolean; override;
function DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal): Boolean; override;
function DrawEdge(DC: HDC; var ARect: TRect; Edge: Cardinal; grfFlags: Cardinal): Boolean; override;
function DrawText(DC: HDC; Str: PChar; Count: Integer; var Rect: TRect; Flags: Cardinal): Integer; Override;
function Ellipse(DC: HDC; x1,y1,x2,y2: Integer): Boolean; override;
@ -213,6 +213,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ =============================================================================
$Log$
Revision 1.89 2004/02/23 18:24:38 mattias
completed new TToolBar
Revision 1.88 2004/02/19 05:07:17 mattias
CreateBitmapFromRawImage now creates mask only if needed