pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

jvcllaz: Fix lcl scaling for TJvJanToggle. Publish Font property. Fix behavior when Width or Height is changed.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7286 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2020-01-14 17:35:06 +00:00
parent 7c25c573a5
commit d44027354c
1 changed files with 80 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

103
components/jvcllaz/run/JvJans/jvjantoggle.pas
View File

@ -25,9 +25,12 @@ type
FInCap: string;
FOutCap: string;
FButtonStyle: TButtonStyle;
FWidthChanged: Boolean;
FHeightChanged: Boolean;
procedure DoToggleChange;
function IsStoredInCap: Boolean;
function IsStoredOutCap: Boolean;
procedure SetToggleState(const AValue: boolean);
{ procedure keepsize(Sender: TObject);}
procedure SetIncolor(const AValue: TToggleColor);
procedure SetOutColor(const AValue: TToggleColor);
procedure SetBackLit(const AValue: boolean);
@ -35,12 +38,17 @@ type
procedure SetMarking(const AValue: boolean);
procedure SetToggleStyle(const AValue: TToggleStyle);
procedure MakeStyle;
procedure SetButtonStyle(const AValue: TButtonStyle);
procedure SetInCap(const AValue: string);
procedure SetOutCap(const AValue: string);
procedure SetButtonStyle(const AValue: TButtonStyle);
protected
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); override;
procedure FontChanged(Sender: TObject); override;
procedure Paint; override;
procedure Resize; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
public
constructor Create(AOwner: TComponent); override;
@ -49,18 +57,20 @@ type
AShift: TShiftState; X, Y: Integer);
published
property ToggleState: Boolean read FToggleState write SetToggleState;
property ToggleStyle: TToggleStyle read FToggleStyle write SetToggleStyle;
property ButtonStyle: TButtonStyle read FButtonstyle
write SetButtonstyle default bsSquare;
property ToggleState: Boolean read FToggleState write SetToggleState default false;
property ToggleStyle: TToggleStyle read FToggleStyle write SetToggleStyle default tsVertical;
property ButtonStyle: TButtonStyle read FButtonstyle write SetButtonstyle default bsSquare;
property BackLit: boolean read FBackLit write SetBackLit default false;
property Marking: boolean read FMarking write SetMarking default true;
property InColor: TToggleColor read FInColor write SetInColor default tcRed;
property InCap: string read FInCap write SetInCap;
property InCap: string read FInCap write SetInCap stored IsStoredInCap;
property OutColor: TToggleColor read FOutColor write SetOutColor default tcGreen;
property OutCap: string read FOutCap write SetOutCap;
property OutCap: string read FOutCap write SetOutCap stored IsStoredOutCap;
property OnToggleChange: TOnToggleChange read FOnToggleChange write FOnToggleChange;
property BorderSpacing;
property Font;
end;
@ -71,11 +81,16 @@ implementation
constructor TJvJanToggle.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 24;
Height := 48;
{
with GetControlClassDefaultSize do
SetInitialBounds(0, 0, CX, CY);
}
ControlStyle := ControlStyle + [csReplicatable];
FButtonStyle := bsSquare;
MakeStyle;
OnMouseDown := @ToggleMouseDown;
// onresize:=keepsize;
FInColor := tcRed;
FoutColor := tcGreen;
FBackLit := false;
@ -84,32 +99,64 @@ begin
FOutCap := 'O';
end;
destructor TJvJanToggle.Destroy;
begin
//mycode
inherited Destroy;
end;
procedure TJvJanToggle.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double);
begin
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
MakeStyle;
end;
procedure TJvJanToggle.FontChanged(Sender: TObject);
begin
inherited;
Invalidate;
end;
function TJvJanToggle.IsStoredInCap: Boolean;
begin
Result := FInCap <> 'I';
end;
function TJvJanToggle.IsStoredOutCap: Boolean;
begin
Result := FOutCap <> 'O';
end;
procedure TJvJanToggle.MakeStyle;
begin
case FToggleStyle of
tsVertical:
begin
Width := 24;
Height := 48;
if FWidthChanged then
SetBounds(Left, Top, Width, Width * 2)
else
if FHeightChanged then
Setbounds(Left, Top, Height div 2, Height)
else
exit;
FIn := Rect(1, 1, Width-1, Width-2);
FOut := Rect(1, Width, Width-2, Height-2);
end;
tsHorizontal:
begin
Width := 48;
Height := 24;
if FWidthChanged then
SetBounds(Left, Top, Width, Width div 2)
else if FHeightChanged then
SetBounds(Left, Top, Height * 2, Height)
else
exit;
FIn := Rect(1, 1, Height-2, Height-2);
FOut := Rect(Height, 1, Width-2, Height-2);
end;
end;
Refresh;
Invalidate; //Refresh;
end;
procedure TJvJanToggle.DoToggleChange;
@ -203,11 +250,12 @@ procedure TJvJanToggle.Paint;
x, y, w, h: integer;
begin
with Canvas do begin
Font.Assign(Self.Font);
Font.Style := Font.Style + [fsBold];
w := TextWidth(s);
h := TextHeight(s);
x := (R.Right - R.Left - w + 1) div 2;
y := (R.Bottom - R.Top - h) div 2;
Font.Style := Font.Style + [fsBold];
Pen.Color := clBlack;
Brush.Style := bsClear;
if FBacklit then
@ -290,7 +338,7 @@ procedure TJvJanToggle.Paint;
end;
end;
if FBackLit then DoLit(ARect, AColor, false);
if FMarking then btncap(ARect, s, AColor, false);
if FMarking then BtnCap(ARect, s, AColor, false);
end;
end;
@ -298,7 +346,7 @@ begin
with Canvas do begin
Brush.Color := clSilver;
Pen.Color := clBlack;
case FButtonstyle of
case FButtonStyle of
bssquare: Rectangle(0, 0, Width, Height);
end;
if FToggleState then begin
@ -312,6 +360,19 @@ begin
end;
end;
procedure TJvJanToggle.Resize;
begin
inherited;
MakeStyle;
end;
procedure TJvJanToggle.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
FWidthChanged := AWidth <> Width;
FHeightChanged := AHeight <> Height;
inherited;
end;
procedure TJvJanToggle.SetToggleState(const AValue: boolean);
begin
if AValue <> FToggleState then
@ -354,12 +415,6 @@ begin
end;
end;
{
procedure TJvJanToggle.keepsize(Sender: TObject);
begin
makestyle;
end; }
procedure TJvJanToggle.SetToggleStyle(const AValue: TToggleStyle);
begin
if AValue <> FToggleStyle then begin