paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-18 23:09:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm

Browse Source 
git-svn-id: trunk@5634 -
This commit is contained in:
micha 2004-07-01 20:42:11 +00:00
parent d808ea8234
commit a3cfd24da5
8 changed files with 131 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/buttons.pp
View File

@ -78,6 +78,9 @@ type
function ChildClassAllowed(ChildClass: TClass): boolean; override;
public
constructor Create(AOwner: TComponent); override;
procedure ExecuteDefaultAction; override;
procedure ExecuteCancelAction; override;
published
property Action;
property Anchors;
@ -330,6 +333,9 @@ end.
{ =============================================================================
$Log$
Revision 1.69 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.68 2004/06/30 11:07:20 micha
implement return key clicks default button; escape key clicks cancel button

9
lcl/controls.pp
View File

@ -267,7 +267,9 @@ type
csNeedsBorderPaint, // not implemented
csParentBackground, // not implemented
csDesignNoSmoothResize, // no WYSIWYG resizing in designer
csDesignFixedBounds // control can not be moved nor resized in designer
csDesignFixedBounds, // control can not be moved nor resized in designer
csHasDefaultAction, // control implements useful ExecuteDefaultAction
csHasCancelAction // control implements useful ExecuteCancelAction
);
TControlStyle = set of TControlStyleType;
@ -1000,6 +1002,8 @@ type
constructor Create(AOwner: TComponent);override;
destructor Destroy; override;
Function PerformTab(ForwardTab: boolean): Boolean; Virtual;
procedure ExecuteDefaultAction; virtual;
procedure ExecuteCancelAction; virtual;
procedure BeginDrag(Immediate: Boolean; Threshold: Integer);
procedure BeginDrag(Immediate: Boolean);
procedure BringToFront;
@ -2326,6 +2330,9 @@ end.
{ =============================================================================
$Log$
Revision 1.219 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.218 2004/07/01 10:08:31 mattias
made key handling more flexible

12
lcl/forms.pp
View File

@ -336,8 +336,8 @@ type
private
FActive: Boolean;
FActiveControl: TWinControl;
FDefaultButton: TControl;
FEscapeButton: TControl;
FDefaultControl: TControl;
FCancelControl: TControl;
FDesigner: TIDesigner;
FDummyTextHeight: Longint;
FFormState: TFormState;
@ -373,8 +373,8 @@ type
procedure SetActive(AValue: Boolean);
procedure SetActiveControl(AWinControl: TWinControl);
procedure SetFormBorderStyle(NewStyle: TFormBorderStyle);
procedure SetEscapeButton(NewButton: TControl);
procedure SetDefaultButton(NewButton: TControl);
procedure SetCancelControl(NewControl: TControl);
procedure SetDefaultControl(NewControl: TControl);
procedure SetDesigner(Value : TIDesigner);
procedure SetFormStyle(Value : TFormStyle);
procedure SetIcon(AValue: TIcon);
@ -450,10 +450,10 @@ type
property ActiveControl: TWinControl read FActiveControl write SetActiveControl;
property BorderStyle: TFormBorderStyle
read FFormBorderStyle write SetFormBorderStyle default bsSizeable;
property EscapeButton: TControl read FEscapeButton write SetEscapeButton;
property CancelControl: TControl read FCancelControl write SetCancelControl;
property Caption stored IsForm;
property Color default clBtnFace;
property DefaultButton: TControl read FDefaultButton write SetDefaultButton;
property DefaultControl: TControl read FDefaultControl write SetDefaultControl;
property Designer: TIDesigner read FDesigner write SetDesigner;
property FormState: TFormState read FFormState;
property FormStyle: TFormStyle read FFormStyle write SetFormStyle

51
lcl/include/buttons.inc
View File

@ -32,7 +32,7 @@ begin
end;
{set the component style to csButton}
fCompStyle := csButton;
ControlStyle:=ControlStyle-[csClickEvents];
ControlStyle:=ControlStyle-[csClickEvents]+[csHasDefaultAction,csHasCancelAction];
TabStop := true;
{set default alignment}
Align := alNone;
@ -80,9 +80,19 @@ end;
procedure TButton.SetParent(AParent: TWinControl);
------------------------------------------------------------------------------}
procedure TButton.SetParent(AParent: TWinControl);
var
Form: TCustomForm;
begin
if Parent=AParent then exit;
inherited SetParent(AParent);
Form := GetParentForm(Self);
if Form <> nil then
begin
if FDefault then
Form.DefaultControl := Self;
if FCancel then
Form.CancelControl := Self;
end;
DoSendBtnDefault;
end;
@ -98,10 +108,13 @@ begin
if FCancel = NewCancel then Exit;
FCancel := NewCancel;
Form := GetParentForm(Self);
if NewCancel then
Form.EscapeButton := Self
else
Form.EscapeButton := nil;
if Form <> nil then
begin
if NewCancel then
Form.CancelControl := Self
else
Form.CancelControl := nil;
end;
end;
{------------------------------------------------------------------------------
@ -116,12 +129,27 @@ begin
if FDefault = Value then Exit;
FDefault := Value;
Form := GetParentForm(Self);
if Value then
Form.DefaultButton := Self
else
Form.DefaultButton := nil;
if Form <> nil then
begin
if Value then
Form.DefaultControl := Self
else
Form.DefaultControl := nil;
end;
DoSendBtnDefault;
End;
end;
procedure TButton.ExecuteDefaultAction;
begin
if FDefault then
Click;
end;
procedure TButton.ExecuteCancelAction;
begin
if FCancel then
Click;
end;
{------------------------------------------------------------------------------
Method: TButton.Click
@ -182,6 +210,9 @@ end;
{ =============================================================================
$Log$
Revision 1.29 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.28 2004/06/30 11:07:20 micha
implement return key clicks default button; escape key clicks cancel button

11
lcl/include/control.inc
View File

@ -527,6 +527,14 @@ begin
end;
end;
procedure TControl.ExecuteDefaultAction;
begin
end;
procedure TControl.ExecuteCancelAction;
begin
end;
{------------------------------------------------------------------------------
function TControl.GetFloating: Boolean;
------------------------------------------------------------------------------}
@ -3191,6 +3199,9 @@ end;
{ =============================================================================
$Log$
Revision 1.200 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.199 2004/06/28 23:46:40 marc
* Fixed compilation on 1.0.10
* Fixed check for override of GetTextBuf and SetTextBuf

48
lcl/include/customform.inc
View File

@ -192,38 +192,37 @@ begin
Result:=FKeyPreview=true;
end;
procedure TCustomForm.SetEscapeButton(NewButton: TControl);
var
lButton: TControl;
procedure TCustomForm.SetCancelControl(NewControl: TControl);
//var
// lControl: TControl;
begin
if NewButton <> FEscapeButton then
if NewControl <> FCancelControl then
begin
// prevent inf. recursion problems
lButton := FEscapeButton;
FEscapeButton := nil;
// TODO: TControl -> TButton so we don't have to check type ?
if lButton <> nil then
(lButton as TButton).Cancel := false;
FEscapeButton := NewButton;
if NewButton <> nil then
(NewButton as TButton).Cancel := true;
// lControl := FCancelControl;
// FCancelControl := nil;
// if lControl <> nil then
// (lControl as TControl).Cancel := false;
FCancelControl := NewControl;
// if NewControl <> nil then
// (NewControl as TControl).Cancel := true;
end;
end;
procedure TCustomForm.SetDefaultButton(NewButton: TControl);
var
lButton: TControl;
procedure TCustomForm.SetDefaultControl(NewControl: TControl);
//var
// lControl: TControl;
begin
if NewButton <> FDefaultButton then
if NewControl <> FDefaultControl then
begin
// prevent inf. recursion problems
lButton := FDefaultButton;
FDefaultButton := nil;
if lButton <> nil then
(lButton as TButton).Default := false;
FDefaultButton := NewButton;
if NewButton <> nil then
(NewButton as TButton).Default := true;
// lControl := FDefaultControl;
// FDefaultControl := nil;
// if lControl <> nil then
// (lControl as TControl).Default := false;
FDefaultControl := NewControl;
// if NewControl <> nil then
// (NewControl as TControl).Default := true;
end;
end;
@ -1642,6 +1641,9 @@ end;
{ =============================================================================
$Log$
Revision 1.142 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.141 2004/06/30 11:07:20 micha
implement return key clicks default button; escape key clicks cancel button

17
lcl/include/wincontrol.inc
View File

@ -2090,26 +2090,24 @@ begin
Key:=VK_UNKNOWN;
PerformTab(not (ssShift in Shift));
end;
// check for special actions handled ourselves
if (Shift = []) and ((Key = VK_RETURN) or (Key = VK_ESCAPE)) then
begin
Form := GetParentForm(Self);
case Key of
VK_RETURN:
begin
if Form.DefaultButton <> nil then begin
(Form.DefaultButton as TButton).Click;
Key:=VK_UNKNOWN;
end;
if Form.DefaultControl <> nil then
Form.DefaultControl.ExecuteDefaultAction;
end;
VK_ESCAPE:
begin
if Form.EscapeButton <> nil then begin
(Form.EscapeButton as TButton).Click;
Key:=VK_UNKNOWN;
end;
if Form.CancelControl <> nil then
Form.CancelControl.ExecuteCancelAction;
end;
end;
Key := VK_UNKNOWN;
end;
end;
@ -3753,6 +3751,9 @@ end;
{ =============================================================================
$Log$
Revision 1.248 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.247 2004/07/01 17:55:55 mattias
LCL navigation keys are now handled after interface handles keys

28
lcl/interfaces/win32/win32callback.inc
View File

@ -1153,9 +1153,12 @@ var
LMessage: TLMessage;
LMKey: TLMKey;
PLMsg: PLMessage;
NotifyUserInput: Boolean;
NotifyUserInput: boolean;
WinProcess: boolean;
OwnerObject: TObject;
begin
// filter messages we want to send to LCL
WinProcess := true;
if (Msg = WM_KILLFOCUS) or (Msg = WM_SETFOCUS) or
((Msg >= WM_KEYFIRST) and (Msg <= WM_KEYLAST)) then
begin
@ -1195,10 +1198,26 @@ begin
if NotifyUserInput then
NotifyApplicationUserInput(PLMsg^.Msg);
DeliverMessage(TObject(Windows.GetProp(Window, 'AWinControl')), PLMsg^);
OwnerObject := TObject(Windows.GetProp(Window, 'AWinControl'));
DeliverMessage(OwnerObject, PLMsg^);
case Msg of
WM_KEYDOWN, WM_KEYUP:
begin
// if not yet processed, resend normally
if LMKey.CharCode <> VK_UNKNOWN then
begin
LMKey.Msg := Msg;
DeliverMessage(OwnerObject, LMKey);
// still not handled? then do default processing
WinProcess := LMKey.CharCode <> VK_UNKNOWN;
end;
end;
end;
end;
Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
if WinProcess then
Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
end;
{------------------------------------------------------------------------------
@ -1256,6 +1275,9 @@ end;
{
$Log$
Revision 1.124 2004/07/01 20:42:11 micha
implement better ExecuteXXAction design; break dependency on TButton class in TCustomForm
Revision 1.123 2004/06/30 10:38:51 micha
fix setcursor to only change cursor within client area, not on scrollbars etc.