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

lcl: TCustomImage.StretchOutEnabled/StrechInEnabled, issue #29605, from Alexey Torgashin

Browse Source 
git-svn-id: trunk@52955 -
This commit is contained in:
mattias 2016-09-11 21:23:48 +00:00
parent 8f3ff56888
commit 2a7d1a624a
2 changed files with 49 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
lcl/extctrls.pp
View File

@ -494,6 +494,8 @@ type
FProportional: Boolean; FProportional: Boolean;
FTransparent: Boolean; FTransparent: Boolean;
FStretch: Boolean; FStretch: Boolean;
FStretchOutEnabled: Boolean;
FStretchInEnabled: Boolean;
FUseAncestorCanvas: boolean; FUseAncestorCanvas: boolean;
FPainting: boolean; FPainting: boolean;
function GetCanvas: TCanvas; function GetCanvas: TCanvas;
@ -504,6 +506,8 @@ type
procedure SetKeepOriginY(AValue: Boolean); procedure SetKeepOriginY(AValue: Boolean);
procedure SetProportional(const AValue: Boolean); procedure SetProportional(const AValue: Boolean);
procedure SetStretch(const AValue : Boolean); procedure SetStretch(const AValue : Boolean);
procedure SetStretchInEnabled(AValue: Boolean);
procedure SetStretchOutEnabled(AValue: Boolean);
procedure SetTransparent(const AValue : Boolean); procedure SetTransparent(const AValue : Boolean);
protected protected
class procedure WSRegisterClass; override; class procedure WSRegisterClass; override;
@ -539,6 +543,8 @@ type
property OnMouseWheelDown; property OnMouseWheelDown;
property OnMouseWheelUp; property OnMouseWheelUp;
property Stretch: Boolean read FStretch write SetStretch default False; property Stretch: Boolean read FStretch write SetStretch default False;
property StretchOutEnabled: Boolean read FStretchOutEnabled write SetStretchOutEnabled default True;
property StretchInEnabled: Boolean read FStretchInEnabled write SetStretchInEnabled default True;
property Transparent: Boolean read FTransparent write SetTransparent default False; property Transparent: Boolean read FTransparent write SetTransparent default False;
property Proportional: Boolean read FProportional write SetProportional default False; property Proportional: Boolean read FProportional write SetProportional default False;
property OnPictureChanged: TNotifyEvent read FOnPictureChanged write FOnPictureChanged; property OnPictureChanged: TNotifyEvent read FOnPictureChanged write FOnPictureChanged;
@ -587,6 +593,8 @@ type
property Proportional; property Proportional;
property ShowHint; property ShowHint;
property Stretch; property Stretch;
property StretchOutEnabled;
property StretchInEnabled;
property Transparent; property Transparent;
property Visible; property Visible;
end; end;

59
lcl/include/customimage.inc
View File

@ -20,6 +20,8 @@ begin
FKeepOriginYWhenClipped := False; FKeepOriginYWhenClipped := False;
FProportional := False; FProportional := False;
FStretch := False; FStretch := False;
FStretchOutEnabled := True;
FStretchInEnabled := True;
FTransparent := False; FTransparent := False;
FPicture := TPicture.Create; FPicture := TPicture.Create;
FPicture.OnChange := @PictureChanged; FPicture.OnChange := @PictureChanged;
@ -97,6 +99,20 @@ begin
PictureChanged(Self); PictureChanged(Self);
end; end;
procedure TCustomImage.SetStretchInEnabled(AValue: Boolean);
begin
if FStretchInEnabled = AValue then Exit;
FStretchInEnabled := AValue;
PictureChanged(Self);
end;
procedure TCustomImage.SetStretchOutEnabled(AValue: Boolean);
begin
if FStretchOutEnabled = AValue then Exit;
FStretchOutEnabled := AValue;
PictureChanged(Self);
end;
procedure TCustomImage.SetTransparent(const AValue : Boolean); procedure TCustomImage.SetTransparent(const AValue : Boolean);
begin begin
if FTransparent = AValue then exit; if FTransparent = AValue then exit;
@ -151,30 +167,37 @@ var
w: Integer; w: Integer;
h: Integer; h: Integer;
ChangeX, ChangeY: Integer; ChangeX, ChangeY: Integer;
PicInside, PicOutside, PicOutsidePartial: boolean;
begin begin
PicWidth := Picture.Width; PicWidth := Picture.Width;
PicHeight := Picture.Height; PicHeight := Picture.Height;
ImgWidth := ClientWidth; ImgWidth := ClientWidth;
ImgHeight := ClientHeight; ImgHeight := ClientHeight;
if Stretch or (Proportional if (PicWidth=0) or (PicHeight=0) then Exit(Rect(0, 0, 0, 0));
and ((PicWidth > ImgWidth) or (PicHeight > ImgHeight))) then begin
if Proportional and (PicWidth > 0) and (PicHeight > 0) then begin
w:=ImgWidth;
h:=(PicHeight*w) div PicWidth;
if h>ImgHeight then begin
h:=ImgHeight;
w:=(PicWidth*h) div PicHeight;
end;
PicWidth:=w;
PicHeight:=h;
end
else begin
PicWidth := ImgWidth;
PicHeight := ImgHeight;
end;
end;
Result:=Rect(0,0,PicWidth,PicHeight); PicInside := (PicWidth<ImgWidth) and (PicHeight<ImgHeight);
PicOutside := (PicWidth>ImgWidth) and (PicHeight>ImgHeight);
PicOutsidePartial := (PicWidth>ImgWidth) or (PicHeight>ImgHeight);
if Stretch or (Proportional and PicOutsidePartial) then
if (FStretchOutEnabled or PicOutside) and
(FStretchInEnabled or PicInside) then
if Proportional then begin
w:=ImgWidth;
h:=(PicHeight*w) div PicWidth;
if h>ImgHeight then begin
h:=ImgHeight;
w:=(PicWidth*h) div PicHeight;
end;
PicWidth:=w;
PicHeight:=h;
end
else begin
PicWidth := ImgWidth;
PicHeight := ImgHeight;
end;
Result := Rect(0, 0, PicWidth, PicHeight);
if Center then if Center then
begin begin