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

implemented interface constraints

Browse Source 
git-svn-id: trunk@5135 -
This commit is contained in:
mattias 2004-02-02 12:44:45 +00:00
parent e315dc4aab
commit 286718c595
15 changed files with 218 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lcl/controls.pp
View File

@ -497,21 +497,36 @@ type
private
FControl: TControl;
FMaxHeight: TConstraintSize;
FMaxInterfaceHeight: integer;
FMaxInterfaceWidth: integer;
FMaxWidth: TConstraintSize;
FMinHeight: TConstraintSize;
FMinInterfaceHeight: integer;
FMinInterfaceWidth: integer;
FMinWidth: TConstraintSize;
FOnChange: TNotifyEvent;
protected
procedure Change; dynamic;
procedure AssignTo(Dest: TPersistent); override;
property Control: TControl read FControl;
procedure SetMaxHeight(Value: TConstraintSize); virtual;
procedure SetMaxWidth(Value: TConstraintSize); virtual;
procedure SetMinHeight(Value: TConstraintSize); virtual;
procedure SetMinWidth(Value: TConstraintSize); virtual;
public
constructor Create(AControl: TControl); virtual;
procedure UpdateInterfaceConstraints; virtual;
procedure SetInterfaceConstraints(MinW, MinH, MaxW, MaxH: integer); virtual;
function EffectiveMinWidth: integer; virtual;
function EffectiveMinHeight: integer; virtual;
function EffectiveMaxWidth: integer; virtual;
function EffectiveMaxHeight: integer; virtual;
public
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property MaxInterfaceHeight: integer read FMaxInterfaceHeight;
property MaxInterfaceWidth: integer read FMaxInterfaceWidth;
property MinInterfaceHeight: integer read FMinInterfaceHeight;
property MinInterfaceWidth: integer read FMinInterfaceWidth;
property Control: TControl read FControl;
published
property MaxHeight: TConstraintSize read FMaxHeight write SetMaxHeight default 0;
property MaxWidth: TConstraintSize read FMaxWidth write SetMaxWidth default 0;
@ -1862,6 +1877,9 @@ end.
{ =============================================================================
$Log$
Revision 1.171 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.170 2004/02/02 11:07:43 mattias
constraints and aligning now work together

8
lcl/include/intfbaselcl.inc
View File

@ -242,6 +242,11 @@ begin
Result := false;
end;
function TInterfaceBase.GetControlConstraints(Constraints: TObject): boolean;
begin
Result:=true;
end;
function TInterfaceBase.GetDCOriginRelativeToWindow(PaintDC: HDC;
WindowHandle: HWND; var OriginDiff: TPoint): boolean;
begin
@ -592,6 +597,9 @@ end;
{ =============================================================================
$Log$
Revision 1.14 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.13 2004/01/12 13:43:12 mattias
improved and activated new statusbar

18
lcl/include/lclintf.inc
View File

@ -156,6 +156,21 @@ begin
Result := InterfaceObject.GetCmdLineParamDescForInterface;
end;
{------------------------------------------------------------------------------
Function: GetControlConstraints
Params: Constraints: TObject
Returns: true on success
Updates the constraints object (e.g. TSizeConstraints) with interface specific
bounds. For instance, vertical scrollbars under gtk are fixed in width. So,
it sets MinInterfaceWidth and MaxInterfaceWidth. This is used by the auto
aligning/sizing algorithms of the LCL.
------------------------------------------------------------------------------}
function GetControlConstraints(Constraints: TObject): boolean;
begin
Result := InterfaceObject.GetControlConstraints(Constraints);
end;
function GetDCOriginRelativeToWindow(PaintDC: HDC; WindowHandle: HWND;
var OriginDiff: TPoint): boolean;
begin
@ -486,6 +501,9 @@ end;
{ =============================================================================
$Log$
Revision 1.12 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.11 2004/01/12 08:36:34 micha
statusbar interface dependent reimplementation (from vincent)

4
lcl/include/lclintfh.inc
View File

@ -60,6 +60,7 @@ function GetBitmapRawImageDescription(Bitmap: HBITMAP; Desc: PRawImageDescriptio
function GetCaretRespondToFocus(handle: HWND; var ShowHideOnFocus: boolean): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetClientBounds(handle : HWND; var ARect: TRect) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetCmdLineParamDescForInterface: string; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetControlConstraints(Constraints: TObject): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetDCOriginRelativeToWindow(PaintDC: HDC; WindowHandle: HWND; var OriginDiff: TPoint): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetDesignerDC(WindowHandle: HWND): HDC; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetDeviceRawImageDescription(DC: HDC; Desc: PRawImageDescription): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -146,6 +147,9 @@ procedure RaiseLastOSError;
{ =============================================================================
$Log$
Revision 1.12 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.11 2004/01/12 08:36:34 micha
statusbar interface dependent reimplementation (from vincent)

41
lcl/include/scrollbar.inc
View File

@ -76,13 +76,18 @@ begin
end;
procedure TScrollBar.SetKind(Value: TScrollBarKind);
var
OldWidth: Integer;
OldHeight: Integer;
begin
if FKind <> Value then
begin
FKind := Value;
if HandleAllocated then
RecreateWnd;
CheckAutoAlignment;
// switch width and height
OldWidth:=Width;
OldHeight:=Height;
RecreateWnd;
SetBounds(Left,Top,OldHeight,OldWidth);
end;
end;
@ -154,36 +159,6 @@ begin
if Assigned(FOnScroll) then FOnScroll(Self, ScrollCode, ScrollPos);
end;
procedure TScrollBar.SetAlign(Value: TAlign);
begin
if Align=Value then exit;
inherited SetAlign(Value);
CheckAutoAlignment;
end;
procedure TScrollBar.SetAnchors(const AValue: TAnchors);
begin
if Anchors=AValue then exit;
inherited SetAnchors(AValue);
CheckAutoAlignment;
end;
procedure TScrollBar.CheckAutoAlignment;
begin
// scrollbars are fixed in width
if Kind=sbHorizontal then begin
if Align=alBottom then
Anchors:=Anchors-[akTop]+[akBottom]
else if Align=alTop then
Anchors:=Anchors+[akTop]-[akBottom];
end else begin
if Align=alRight then
Anchors:=Anchors-[akLeft]+[akRight]
else if Align=alLeft then
Anchors:=Anchors+[akLeft]-[akRight];
end;
end;
procedure TScrollBar.DoScroll(var Message: TLMScroll);
var
ScrollPos: Integer;

64
lcl/include/sizeconstraints.inc
View File

@ -35,6 +35,70 @@ begin
FMaxHeight:= 0;
FMinWidth:= 0;
FMinHeight:= 0;
UpdateInterfaceConstraints;
end;
{------------------------------------------------------------------------------
procedure TSizeConstraints.UpdateInterfaceConstraints;
Asks interface for constraints.
------------------------------------------------------------------------------}
procedure TSizeConstraints.UpdateInterfaceConstraints;
begin
GetControlConstraints(Self);
end;
procedure TSizeConstraints.SetInterfaceConstraints(MinW, MinH,
MaxW, MaxH: integer);
begin
if (FMinInterfaceWidth=MinW)
and (FMinInterfaceHeight=MinH)
and (FMaxInterfaceWidth=MaxW)
and (FMaxInterfaceHeight=MaxH) then exit;
FMinInterfaceWidth:=MinW;
FMinInterfaceHeight:=MinH;
FMaxInterfaceWidth:=MaxW;
FMaxInterfaceHeight:=MaxH;
FControl.RequestAlign;
end;
function TSizeConstraints.EffectiveMinWidth: integer;
begin
if (MinInterfaceWidth=0)
or ((MinWidth>MinInterfaceWidth) and (MinWidth<=MaxInterfaceWidth)) then
Result:=MinWidth
else
Result:=MinInterfaceWidth;
end;
function TSizeConstraints.EffectiveMinHeight: integer;
begin
if (MinInterfaceHeight=0)
or ((MinHeight>MinInterfaceHeight) and (MinHeight<=MaxInterfaceHeight)) then
Result:=MinHeight
else
Result:=MinInterfaceHeight;
end;
function TSizeConstraints.EffectiveMaxWidth: integer;
begin
if (MaxInterfaceWidth=0)
or ((MaxWidth<MaxInterfaceWidth) and (MaxWidth>=MinInterfaceWidth)) then
Result:=MaxWidth
else
Result:=MaxInterfaceWidth;
end;
function TSizeConstraints.EffectiveMaxHeight: integer;
begin
if (MaxInterfaceHeight=0)
or ((MaxHeight<MaxInterfaceHeight) and (MaxHeight>=MinInterfaceHeight)) then
Result:=MaxHeight
else
Result:=MaxInterfaceHeight;
end;
{------------------------------------------------------------------------------

20
lcl/include/wincontrol.inc
View File

@ -98,14 +98,16 @@ var
function ConstraintWidth(NewWidth: integer): integer;
begin
Result:=NewWidth;
if (MaxWidth>MinWidth) and (Result>MaxWidth) then Result:=MaxWidth;
if (MaxWidth>=MinWidth) and (Result>MaxWidth) and (MaxWidth>0) then
Result:=MaxWidth;
if Result<MinWidth then Result:=MinWidth;
end;
function ConstraintHeight(NewHeight: integer): integer;
begin
Result:=NewHeight;
if (MaxHeight>MinHeight) and (Result>MaxHeight) then Result:=MaxHeight;
if (MaxHeight>=MinHeight) and (Result>MaxHeight) and (MaxHeight>0) then
Result:=MaxHeight;
if Result<MinHeight then Result:=MinHeight;
end;
@ -119,13 +121,13 @@ var
with Control do begin
// get constraints
MinWidth:=Constraints.MinWidth;
MinWidth:=Constraints.EffectiveMinWidth;
if MinWidth<0 then MinWidth:=0;
MaxWidth:=Constraints.MaxWidth;
MinHeight:=Constraints.MinHeight;
MaxWidth:=Constraints.EffectiveMaxWidth;
MinHeight:=Constraints.EffectiveMinHeight;
if MinHeight<0 then MinHeight:=0;
MaxHeight:=Constraints.MaxHeight;
MaxHeight:=Constraints.EffectiveMaxHeight;
// get default bounds
NewLeft:=Left;
NewTop:=Top;
@ -2885,6 +2887,7 @@ begin
if HandleAllocated then
RaiseError('Handle already created');
CNSendMessage(LM_CREATE, Self, nil);
Constraints.UpdateInterfaceConstraints;
FFlags:=FFlags-[wcfColorChanged,wcfFontChanged];
if not HandleAllocated then
RaiseError('Handle creation failed');
@ -3266,6 +3269,9 @@ end;
{ =============================================================================
$Log$
Revision 1.195 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.194 2004/02/02 11:07:43 mattias
constraints and aligning now work together

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

@ -93,7 +93,8 @@ type
lgsMenu,
lgsMenuitem,
lgsList,
lgsScrollbar,
lgsVerticalScrollbar,
lgsHorizontalScrollbar,
lgsTooltip,
lgsUserDefined
);
@ -109,7 +110,8 @@ const
'menu',
'menuitem',
'list',
'scrollbar',
'vertical scrollbar',
'horizontal scrollbar',
'tooltip',
''
);

42
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -41,6 +41,45 @@ begin
Result:='';
end;
{------------------------------------------------------------------------------
Function: GetControlConstraints
Params: Constraints: TObject
Returns: true on success
Updates the constraints object (e.g. TSizeConstraints) with interface specific
bounds.
------------------------------------------------------------------------------}
function TGTKObject.GetControlConstraints(Constraints: TObject): boolean;
var
SizeConstraints: TSizeConstraints;
Widget: PGtkWidget;
MinWidth: Integer;
MinHeight: Integer;
begin
Result:=true;
if Constraints is TSizeConstraints then begin
SizeConstraints:=TSizeConstraints(Constraints);
if (SizeConstraints.Control=nil) then exit;
// TScrollBar
if SizeConstraints.Control is TScrollBar then begin
MinWidth := 0;
MinHeight := 0;
if TScrollBar(SizeConstraints.Control).Kind=sbHorizontal then begin
Widget:=GetStyleWidget(lgsHorizontalScrollbar);
MinHeight:=Widget^.requisition.Height;
end else begin
Widget:=GetStyleWidget(lgsVerticalScrollbar);
MinWidth:=Widget^.requisition.Width;
end;
SizeConstraints.SetInterfaceConstraints(MinWidth,MinHeight,
MinWidth,MinHeight);
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetListBoxIndexAtY
Params: ListBox:
@ -293,6 +332,9 @@ end;
{ =============================================================================
$Log$
Revision 1.13 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.12 2004/01/22 11:23:36 mattias
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent

4
lcl/interfaces/gtk/gtklclintfh.inc
View File

@ -31,6 +31,7 @@
//##apiwiz##sps## // Do not remove
function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;
function GetControlConstraints(Constraints: TObject): boolean; override;
function GetListBoxIndexAtY(ListBox: TComponent; y: integer): integer; override;
function GetListBoxItemRect(ListBox: TComponent; Index: integer; var ARect: TRect): boolean; override;
@ -45,6 +46,9 @@ procedure StatusBarUpdate(StatusBar: TObject); override;
{ =============================================================================
$Log$
Revision 1.10 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.9 2004/01/12 08:36:34 micha
statusbar interface dependent reimplementation (from vincent)

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

@ -1101,7 +1101,7 @@ begin
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLBAR) then
begin
// the width of a scrollbar is fixed and depends only on the theme
gtk_widget_size_request (widget, @Requisition);
gtk_widget_size_request(widget, @Requisition);
if GtkWidgetIsA(Widget, GTK_TYPE_HSCROLLBAR) then
begin
NewHeight:=Requisition.height;
@ -9184,6 +9184,9 @@ end;
{ =============================================================================
$Log$
Revision 1.459 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.458 2004/02/02 00:41:06 mattias
TScrollBar now automatically checks Align and Anchors for useful values

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

@ -5067,6 +5067,7 @@ var
VBox: PGtkWidget;
AddToStyleWindow: Boolean;
StyleWindowWidget: PGtkWidget;
Requisition: TGtkRequisition;
begin
Result := nil;
if Styles=nil then exit;
@ -5144,9 +5145,14 @@ begin
StyleObject^.Widget := GTK_LIST_NEW;
end
else
If AnsiCompareText(WName,LazGtkStyleNames[lgsScrollbar])=0 then begin
lgs:=lgsScrollbar;
StyleObject^.Widget := gtk_hscrollbar_new(nil);//can't dif. between Horiz/Vert. Styles
If AnsiCompareText(WName,LazGtkStyleNames[lgsVerticalScrollbar])=0 then begin
lgs:=lgsVerticalScrollbar;
StyleObject^.Widget := gtk_vscrollbar_new(nil);
end
else
If AnsiCompareText(WName,LazGtkStyleNames[lgsHorizontalScrollbar])=0 then begin
lgs:=lgsHorizontalScrollbar;
StyleObject^.Widget := gtk_hscrollbar_new(nil);
end
else
If AnsiCompareText(WName,LazGtkStyleNames[lgsTooltip])=0 then begin
@ -5192,6 +5198,7 @@ begin
WidgetName:='LazStyle'+WName;
gtk_widget_set_name(StyleObject^.Widget,PChar(WidgetName));
gtk_widget_ensure_style(StyleObject^.Widget);
gtk_widget_size_request(StyleObject^.widget, @Requisition);
StyleObject^.Style:=gtk_widget_get_style(StyleObject^.Widget);
// ToDo: find out, why sometimes the style is not initialized.
// for example: why the following occurs:
@ -5491,7 +5498,7 @@ begin
COLOR_FORM: Style := GetStyle(lgsWindow);
COLOR_BTNFACE: Style := GetStyle(lgsButton);
COLOR_MENU: Style := GetStyle(lgsMenu);
COLOR_SCROLLBAR: Style := GetStyle(lgsScrollbar);
COLOR_SCROLLBAR: Style := GetStyle(lgsHorizontalScrollbar);
end;
If Style = nil then
exit;
@ -6302,6 +6309,9 @@ end;
{ =============================================================================
$Log$
Revision 1.253 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.252 2004/02/02 00:41:06 mattias
TScrollBar now automatically checks Align and Anchors for useful values

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

@ -5107,17 +5107,13 @@ begin
end;
SM_CXHSCROLL:
begin
P := GTK_hscrollbar_new(nil);
gtk_widget_show(P);
P:=GetStyleWidget(lgsVerticalScrollbar);
Result := GTK_Widget(P)^.requisition.Width;
GTK_Widget_Destroy(P);
end;
SM_CYHSCROLL:
begin
P := GTK_hscrollbar_new(nil);
gtk_widget_show(P);
P:=GetStyleWidget(lgsHorizontalScrollbar);
Result := GTK_Widget(P)^.requisition.Height;
GTK_Widget_Destroy(P);
end;
SM_CXHTHUMB:
begin
@ -5245,17 +5241,13 @@ begin
end;
SM_CXVSCROLL:
begin
P := GTK_vscrollbar_new(nil);
gtk_widget_show(P);
P:=GetStyleWidget(lgsVerticalScrollbar);
Result := GTK_Widget(P)^.requisition.Width;
GTK_Widget_Destroy(P);
end;
SM_CYVSCROLL:
begin
P := GTK_vscrollbar_new(nil);
gtk_widget_show(P);
P:=GetStyleWidget(lgsHorizontalScrollbar);
Result := GTK_Widget(P)^.requisition.Height;
GTK_Widget_Destroy(P);
end;
SM_CYCAPTION:
begin
@ -8701,6 +8693,9 @@ end;
{ =============================================================================
$Log$
Revision 1.323 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.322 2004/01/26 11:55:35 mattias
fixed resizing synedit

7
lcl/lclintf.pas
View File

@ -49,9 +49,9 @@ uses
{$endif}
{$DEFINE ClientRectBugFix}
// All winapi related stuff
// All winapi related stuff (Delphi compatible)
{$I winapih.inc}
// All interface communication
// All interface communication (Our additions)
{$I lclintfh.inc}
@ -151,6 +151,9 @@ end.
{
$Log$
Revision 1.7 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.6 2003/11/27 23:02:30 mattias
removed menutype.pas

7
lcl/stdctrls.pp
View File

@ -86,15 +86,13 @@ type
procedure CreateWnd; override;
procedure Change; dynamic;
procedure Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer); dynamic;
procedure SetAlign(Value: TAlign); override;
procedure SetAnchors(const AValue: TAnchors); override;
procedure CheckAutoAlignment;
public
constructor Create(AOwner: TComponent); override;
procedure SetParams(APosition, AMin, AMax: Integer);
published
property Align;
property Anchors;
property Constraints;
property Ctl3D;
property DragCursor;
property DragKind;
@ -1478,6 +1476,9 @@ end.
{ =============================================================================
$Log$
Revision 1.120 2004/02/02 12:44:45 mattias
implemented interface constraints
Revision 1.119 2004/02/02 00:41:06 mattias
TScrollBar now automatically checks Align and Anchors for useful values