mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-06-02 01:32:41 +02:00
578 lines
17 KiB
ObjectPascal
578 lines
17 KiB
ObjectPascal
{ -------------------------------------------
|
|
CarbonButtons.pp - Carbon buttons classes
|
|
-------------------------------------------
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
unit CarbonButtons;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
// defines
|
|
{$I carbondefines.inc}
|
|
|
|
uses
|
|
// rtl+ftl
|
|
Classes, SysUtils,
|
|
// carbon bindings
|
|
MacOSAll,
|
|
// LCL Carbon
|
|
CarbonPrivate, CarbonProc,
|
|
CarbonDbgConsts,
|
|
// LCL
|
|
LCLMessageGlue, LCLType, Graphics;
|
|
|
|
type
|
|
TUpdateValueEvent = procedure (Sender: TObject; CurrentValue: Integer; var AValue: Integer) of object;
|
|
|
|
{ TCarbonCustomCheckBox }
|
|
|
|
TCarbonCustomCheckBox = class(TCarbonControl)
|
|
private
|
|
fSupressNotify : Boolean;
|
|
LastState: Integer;
|
|
isSetState: Boolean;
|
|
public
|
|
UpdateValue: TUpdateValueEvent;
|
|
class function GetValidEvents: TCarbonControlEvents; override;
|
|
procedure Hit({%H-}AControlPart: ControlPartCode); override;
|
|
procedure ValueChanged; override;
|
|
function RetrieveState: Integer; virtual;
|
|
procedure SetState(AState: Integer; NotifyChangeState: Boolean); virtual;
|
|
end;
|
|
|
|
{ TCarbonCheckBox }
|
|
|
|
TCarbonCheckBox = class(TCarbonCustomCheckBox)
|
|
protected
|
|
procedure CreateWidget(const AParams: TCreateParams); override;
|
|
public
|
|
procedure BoundsChanged; override;
|
|
end;
|
|
|
|
{ TCarbonToggleBox }
|
|
|
|
TCarbonToggleBox = class(TCarbonCustomCheckBox)
|
|
protected
|
|
procedure CreateWidget(const AParams: TCreateParams); override;
|
|
end;
|
|
|
|
{ TCarbonRadioButton }
|
|
|
|
TCarbonRadioButton = class(TCarbonCustomCheckBox)
|
|
protected
|
|
procedure CreateWidget(const AParams: TCreateParams); override;
|
|
public
|
|
procedure ValueChanged; override;
|
|
procedure BoundsChanged; override;
|
|
end;
|
|
|
|
{ TCarbonCustomButton }
|
|
|
|
TCarbonCustomButton = class(TCarbonControl)
|
|
public
|
|
class function GetValidEvents: TCarbonControlEvents; override;
|
|
procedure Hit({%H-}AControlPart: ControlPartCode); override;
|
|
public
|
|
procedure SetDefault(ADefault: Boolean); virtual;
|
|
end;
|
|
|
|
{ TCarbonButton }
|
|
|
|
TCarbonButton = class(TCarbonCustomButton)
|
|
protected
|
|
procedure CreateWidget(const AParams: TCreateParams); override;
|
|
public
|
|
procedure BoundsChanged; override;
|
|
end;
|
|
|
|
{ TCarbonBitBtn }
|
|
|
|
TCarbonBitBtn = class(TCarbonCustomButton)
|
|
private
|
|
fPlacement : ControlButtonTextPlacement;
|
|
fAlignment : ControlButtonTextAlignment;
|
|
CustomFont : Boolean;
|
|
protected
|
|
procedure CreateWidget(const AParams: TCreateParams); override;
|
|
procedure UpdateButtonStyle;
|
|
public
|
|
function GetPreferredSize: TPoint; override;
|
|
procedure SetFont(const AFont: TFont); override;
|
|
procedure SetGlyph(Glyph: CGImageRef); virtual;
|
|
procedure SetLayout(APlacement: ControlButtonTextPlacement; ATextAlign: ControlButtonTextAlignment); virtual;
|
|
procedure SetDefault({%H-}ADefault: Boolean); override;
|
|
function GetBounds(var ARect:TRect):Boolean;override;
|
|
function SetBounds(const ARect: TRect): Boolean; override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{ TCarbonCustomCheckBox }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomCheckBox.GetValidEvents
|
|
Returns: Set of events with installed handlers
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonCustomCheckBox.GetValidEvents: TCarbonControlEvents;
|
|
begin
|
|
Result := [cceValueChanged, cceHit];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomCheckBox.Hit
|
|
Params: AControlPart - Hitted control part
|
|
|
|
Hit event handler
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCustomCheckBox.Hit(AControlPart: ControlPartCode);
|
|
begin
|
|
// do nothing, because value changed will be fired immediately
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomCheckBox.ValueChanged
|
|
|
|
Value changed event handler
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCustomCheckBox.ValueChanged;
|
|
var
|
|
NewState: Integer;
|
|
RS: Integer;
|
|
begin
|
|
if not isSetState and Assigned(UpdateValue) then begin
|
|
RS:=RetrieveState;
|
|
NewState:=RS;
|
|
UpdateValue(Self, LastState, NewState);
|
|
if NewState<>RS then SetValue(NewState);
|
|
end;
|
|
LastState:=RetrieveState;
|
|
if not fSupressNotify then
|
|
LCLSendChangedMsg(LCLObject)
|
|
else
|
|
fSupressNotify := False;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomCheckBox.RetrieveState
|
|
Returns: State of Carbon custom check box
|
|
------------------------------------------------------------------------------}
|
|
function TCarbonCustomCheckBox.RetrieveState: Integer;
|
|
begin
|
|
Result := GetControl32BitValue(ControlRef(Widget));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomCheckBox.SetState
|
|
Params: AState - New state
|
|
|
|
Sets the new state of Carbon custom check box
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCustomCheckBox.SetState(AState: Integer; NotifyChangeState: Boolean);
|
|
begin
|
|
if RetrieveState=AState then Exit;
|
|
isSetState:=True;
|
|
fSupressNotify := not NotifyChangeState;
|
|
SetControl32BitValue(ControlRef(Widget), AState);
|
|
LastState:=AState;
|
|
isSetState:=False;
|
|
end;
|
|
|
|
{ TCarbonCheckBox }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCheckBox.CreateWidget
|
|
Params: AParams - Creation parameters
|
|
|
|
Creates Carbon check box
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCheckBox.CreateWidget(const AParams: TCreateParams);
|
|
var
|
|
Control: ControlRef;
|
|
Value: UInt32;
|
|
begin
|
|
Value := 0;
|
|
|
|
if OSError(
|
|
CreateCheckBoxControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
|
|
nil, Value, True, Control{%H-}),
|
|
Self, SCreateWidget, 'CreateCheckBoxControl') then RaiseCreateWidgetError(LCLObject);
|
|
|
|
Widget := Control;
|
|
|
|
inherited;
|
|
|
|
SetText(AParams.Caption);
|
|
end;
|
|
|
|
const
|
|
// values are used from Interface Builder
|
|
StdCheckBoxNormalSize = 18;
|
|
StdCheckBoxSmallSize = 12;
|
|
StdCheckBoxTinySize = 0; // 10
|
|
|
|
procedure TCarbonCheckBox.BoundsChanged;
|
|
begin
|
|
inherited BoundsChanged;
|
|
SetControlViewStyle(Widget, StdCheckBoxTinySize, StdCheckBoxSmallSize, StdCheckBoxNormalSize);
|
|
end;
|
|
|
|
{ TCarbonToggleBox }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonToggleBox.CreateWidget
|
|
Params: AParams - Creation parameters
|
|
|
|
Creates Carbon toggle box
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonToggleBox.CreateWidget(const AParams: TCreateParams);
|
|
var
|
|
Control: ControlRef;
|
|
Value: UInt32;
|
|
begin
|
|
Value := 0;
|
|
if OSError(
|
|
CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
|
|
nil, kControlBevelButtonNormalBevel,
|
|
kControlBehaviorToggles, nil, 0, 0, 0, Control{%H-}),
|
|
Self, SCreateWidget, SCreateBevelButton) then RaiseCreateWidgetError(LCLObject);
|
|
|
|
Widget := Control;
|
|
|
|
inherited;
|
|
|
|
SetText(AParams.Caption);
|
|
SetControl32BitValue(Control, Value);
|
|
end;
|
|
|
|
{ TCarbonRadioButton }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonRadioButton.CreateWidget
|
|
Params: AParams - Creation parameters
|
|
|
|
Creates Carbon radio button
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonRadioButton.CreateWidget(const AParams: TCreateParams);
|
|
var
|
|
Control: ControlRef;
|
|
Value: UInt32;
|
|
begin
|
|
Value := 0;
|
|
if OSError(
|
|
CreateRadioButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
|
|
nil, Value, True, Control{%H-}),
|
|
Self, SCreateWidget, 'CreateRadioButtonControl') then RaiseCreateWidgetError(LCLObject);
|
|
|
|
Widget := Control;
|
|
|
|
inherited;
|
|
|
|
SetText(AParams.Caption);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonRadioButton.ValueChanged
|
|
|
|
Value changed event handler
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonRadioButton.ValueChanged;
|
|
var
|
|
Parent : HIViewRef;
|
|
v : HIViewRef;
|
|
ctrl : TCarbonControl;
|
|
begin
|
|
Parent := HIViewGetSuperview(Widget);
|
|
if not Assigned(Parent) then Exit;
|
|
|
|
|
|
if RetrieveState<>kControlCheckBoxUncheckedValue then
|
|
begin
|
|
v := HIViewGetFirstSubview(Parent);
|
|
while Assigned(v) do
|
|
begin
|
|
if (v <> Widget) then
|
|
begin
|
|
ctrl := GetCarbonControl(v);
|
|
if ctrl is TCarbonRadioButton then
|
|
TCarbonRadioButton(ctrl).SetState(kControlCheckBoxUncheckedValue, True);
|
|
end;
|
|
v := HIViewGetNextView(v);
|
|
end;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
const
|
|
// values are used from Interface Builder
|
|
StdRadioButtonNormalSize = 16;
|
|
StdRadioButtonSmallSize = 14;
|
|
StdRadioButtonTinySize = 0; // 10
|
|
|
|
procedure TCarbonRadioButton.BoundsChanged;
|
|
begin
|
|
inherited BoundsChanged;
|
|
SetControlViewStyle(Widget, StdRadioButtonTinySize, StdRadioButtonSmallSize, StdRadioButtonNormalSize);
|
|
end;
|
|
|
|
{ TCarbonCustomButton }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomButton.GetValidEvents
|
|
Returns: Set of events with installed handlers
|
|
------------------------------------------------------------------------------}
|
|
class function TCarbonCustomButton.GetValidEvents: TCarbonControlEvents;
|
|
begin
|
|
Result := [cceHit];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomButton.Hit
|
|
Params: AControlPart - Hitted control part
|
|
|
|
Hit event handler
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCustomButton.Hit(AControlPart: ControlPartCode);
|
|
begin
|
|
LCLSendClickedMsg(LCLObject);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonCustomButton.SetDefault
|
|
Params: ADefault - Is default
|
|
|
|
Sets the default indication
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonCustomButton.SetDefault(ADefault: Boolean);
|
|
begin
|
|
OSError(
|
|
SetControlData(ControlRef(Widget), kControlEntireControl,
|
|
kControlPushButtonDefaultTag, SizeOf(Boolean), @ADefault),
|
|
Self, 'SetDefault', SSetData);
|
|
end;
|
|
|
|
{ TCarbonButton }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonButton.CreateWidget
|
|
Params: AParams - Creation parameters
|
|
|
|
Creates Carbon button
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonButton.CreateWidget(const AParams: TCreateParams);
|
|
var
|
|
Control: ControlRef;
|
|
begin
|
|
// create the button at bounds
|
|
if OSError(
|
|
CreatePushButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
|
|
nil, Control{%H-}),
|
|
Self, SCreateWidget, 'CreatePushButtonControl') then RaiseCreateWidgetError(LCLObject);
|
|
|
|
Widget := Control;
|
|
|
|
inherited;
|
|
|
|
SetText(AParams.Caption);
|
|
end;
|
|
|
|
const
|
|
// values are used from Interface Builder, should (can?) be evaluated from themes
|
|
MaxPushButtonHeight = 22;
|
|
StdPushButtonNormalHeight = 20;
|
|
StdPushButtonSmallHeight = 17;
|
|
StdPushButtonTinyHeight = 0; // 14
|
|
|
|
NormalPushBtnAddV = 2;
|
|
SmallPushBtnAddV = 1;
|
|
TinyPushBtnAddV = 0;
|
|
|
|
function PushBtnAddV(PushBtnStyle: Integer=kThemePushButtonNormal): Integer;
|
|
begin
|
|
case PushBtnStyle of
|
|
kThemePushButtonMini: Result:=TinyPushBtnAddV;
|
|
kThemePushButtonSmall: Result:=SmallPushBtnAddV;
|
|
kThemePushButtonNormal: Result:=NormalPushBtnAddV;
|
|
else
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure GetBevelButtonStyle(const r: TRect; var ButtonStyle: ThemeButtonKind; var ThemeFont: ThemeFontID);
|
|
var
|
|
h : Integer;
|
|
begin
|
|
h := r.Bottom - r.Top;
|
|
if h < StdPushButtonSmallHeight-1 then
|
|
begin {tiny pushbutton}
|
|
ButtonStyle := kThemePushButtonMini;
|
|
ThemeFont := kThemeMiniSystemFont;
|
|
end
|
|
else if h < StdPushButtonNormalHeight-1 then
|
|
begin {small pushbutton}
|
|
ButtonStyle := kThemePushButtonSmall;
|
|
ThemeFont := kThemeSmallSystemFont;
|
|
end
|
|
else if h <= MaxPushButtonHeight then
|
|
begin {normal pushbutton}
|
|
ButtonStyle := kThemePushButtonNormal;
|
|
ThemeFont := kThemePushButtonFont;
|
|
end
|
|
else begin {bevelbutton}
|
|
ButtonStyle := kThemeRoundedBevelButton;
|
|
ThemeFont := kThemeSystemFont;
|
|
end;
|
|
end;
|
|
|
|
procedure TCarbonButton.BoundsChanged;
|
|
begin
|
|
inherited BoundsChanged;
|
|
SetControlViewStyle(Widget, StdPushButtonTinyHeight, StdPushButtonSmallHeight, StdPushButtonNormalHeight);
|
|
end;
|
|
|
|
{ TCarbonBitBtn }
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonBitBtn.CreateWidget
|
|
Params: AParams - Creation parameters
|
|
|
|
Creates Carbon bitmap button
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonBitBtn.CreateWidget(const AParams: TCreateParams);
|
|
var
|
|
Control: ControlRef;
|
|
begin
|
|
if OSError(
|
|
CreateBevelButtonControl(GetTopParentWindow, ParamsToCarbonRect(AParams),
|
|
nil, kControlBevelButtonLargeBevel, kControlBehaviorPushbutton,
|
|
nil, 0, 0, 0, Control{%H-}),
|
|
Self, SCreateWidget, SCreateBevelButton) then RaiseCreateWidgetError(LCLObject);
|
|
|
|
Widget := Control;
|
|
|
|
inherited;
|
|
|
|
SetText(AParams.Caption);
|
|
|
|
UpdateButtonStyle;
|
|
end;
|
|
|
|
procedure TCarbonBitBtn.UpdateButtonStyle;
|
|
var
|
|
bnds : TRect;
|
|
ButtonKind : ThemeButtonKind;
|
|
FontStyle : ControlFontStyleRec;
|
|
themeid : ThemeFontID;
|
|
begin
|
|
GetBounds(bnds{%H-});
|
|
GetBevelButtonStyle(bnds, ButtonKind{%H-}, themeid{%H-});
|
|
|
|
if not CustomFont then
|
|
begin
|
|
FillChar(FontStyle{%H-}, sizeof(FontStyle), 0);
|
|
FontStyle.font := themeid;
|
|
FontStyle.flags := kControlUseThemeFontIDMask;
|
|
OSError(SetControlFontStyle(ControlRef(Widget), FontStyle),
|
|
Self, 'UpdateButtonStyle', SSetFontStyle, 'kControlBevelButtonKindTag');
|
|
end;
|
|
|
|
OSError(SetControlData(ControlRef(Widget), kControlEntireControl,
|
|
kControlBevelButtonKindTag, SizeOf(ThemeButtonKind), @ButtonKind),
|
|
Self, 'UpdateButtonStyle', SSetData, 'kControlBevelButtonKindTag');
|
|
end;
|
|
|
|
function TCarbonBitBtn.GetPreferredSize: TPoint;
|
|
begin
|
|
Result:=inherited GetPreferredSize;
|
|
Result.Y := 20 + PushBtnAddV;
|
|
end;
|
|
|
|
procedure TCarbonBitBtn.SetFont(const AFont: TFont);
|
|
begin
|
|
inherited;
|
|
CustomFont:=(AFont.Name<>'default') and (AFont.Name<>'');
|
|
UpdateButtonStyle;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonBitBtn.SetGlyph
|
|
Params: AGlyph - New glyph bitmap
|
|
|
|
Sets the glyph bitmap
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonBitBtn.SetGlyph({const AGlyph: TBitmap} Glyph: CGImageRef);
|
|
var
|
|
ContentInfo: ControlButtonContentInfo;
|
|
begin
|
|
ContentInfo.imageRef := Glyph;
|
|
if Assigned(Glyph) then
|
|
ContentInfo.contentType := kControlContentCGImageRef
|
|
else
|
|
ContentInfo.contentType := kControlContentTextOnly;
|
|
|
|
try
|
|
OSError(SetBevelButtonContentInfo(ControlRef(Widget), @ContentInfo),
|
|
Self, 'SetGlyph', 'SetBevelButtonContentInfo');
|
|
finally
|
|
CGImageRelease(ContentInfo.imageRef);
|
|
end;
|
|
UpdateButtonStyle;
|
|
//SetLayout((LCLObject as TCustomBitBtn).Layout);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonBitBtn.SetLayout
|
|
Params: ALayout - Bitmap and caption layout
|
|
|
|
Sets the bitmap and caption layout
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonBitBtn.SetLayout(APlacement: ControlButtonTextPlacement;
|
|
ATextAlign: ControlButtonTextAlignment);
|
|
begin
|
|
OSError(SetBevelButtonTextPlacement(ControlRef(Widget), APlacement),
|
|
Self, 'SetLayout', 'SetBevelButtonTextPlacement');
|
|
OSError(SetBevelButtonTextAlignment(ControlRef(Widget), ATextAlign, 0),
|
|
Self, 'SetLayout', 'SetBevelButtonTextAlignment');
|
|
fPlacement := APlacement;
|
|
fAlignment := ATextAlign;
|
|
UpdateButtonStyle;
|
|
Invalidate;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCarbonBitBtn.SetDefault
|
|
Params: ADefault - Is default
|
|
|
|
Sets the default indication
|
|
------------------------------------------------------------------------------}
|
|
procedure TCarbonBitBtn.SetDefault(ADefault: Boolean);
|
|
begin
|
|
// not supported
|
|
end;
|
|
|
|
function TCarbonBitBtn.GetBounds(var ARect:TRect):Boolean;
|
|
begin
|
|
Result:=inherited GetBounds(ARect);
|
|
inc(ARect.Bottom, PushBtnAddV);
|
|
end;
|
|
|
|
function TCarbonBitBtn.SetBounds(const ARect: TRect): Boolean;
|
|
var
|
|
r : TRect;
|
|
begin
|
|
r:=ARect;
|
|
dec(r.Bottom, PushBtnAddV);
|
|
Result:=inherited SetBounds(r);
|
|
UpdateButtonStyle;
|
|
end;
|
|
|
|
end.
|
|
|