{ /*************************************************************************** switches.pp License: Modified LGPL (with linking exception) See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution, for details about the license. Autho: Werner Pamler ***************************************************************************** } unit Switches; {$mode objfpc}{$H+} interface uses LCLIntf, LCLType, LMessages, LCLVersion, Graphics, GraphType, Classes, SysUtils, Types, Controls, ExtCtrls, ImgList; type TSwitchBorderStyle = ( bsNone, bsThin, bsThick, bsThin3D, bsThick3D, bsNoneRounded, bsThinRounded, bsThickRounded ); TSwitchMode = (smClick, smDblClick, smSlide, smSlideDblClick); TSwitchOrientation = (soHorizontal, soVertical); TSwitchAnimationEffect = (saeBlendColors, saeBlendImages, saeRotateImages); TSwitchAnimationEffects = set of TSwitchAnimationEffect; TCustomOnOffSwitch = class(TCustomControl) private const DEFAULT_BUTTON_SIZE = 24; private FAnimated: Boolean; FAnimationEffects: TSwitchAnimationEffects; FAnimationTimer: TTimer; FBorderStyle: TSwitchBorderStyle; FButtonPos: Integer; FButtonSize: Integer; FCaptions: array[boolean] of string; FChecked: Boolean; FCheckedAfterAnimation: Boolean; FColors: array [0..2] of TColor; FInverse: Boolean; FDragging: Boolean; FMaxDistance: Integer; FFlippedColors: Boolean; FTogglePending: Boolean; FMousePt: TPoint; FButtonRect: TRect; FReadOnly: Boolean; FShowButtonBorder: Boolean; FShowCaption: Boolean; FShowFocusRect: Boolean; FSwitchMode: TSwitchMode; FOnChange: TNotifyEvent; FDblClickTimer: TTimer; FPicture: array[boolean] of TPicture; FImageIndex: array[boolean] of TImageIndex; FImageListChangeLink: TChangeLink; FImages: TCustomImagelist; FImagesWidth: Integer; function GetBorderWidth: Integer; function GetCaptions(AChecked: Boolean): String; function GetColors(AIndex: Integer): TColor; function GetImageIndex(AChecked: Boolean): TImageIndex; function GetOrientation: TSwitchOrientation; function GetPicture(AChecked: Boolean): TPicture; procedure SetAnimated(AValue: Boolean); procedure SetBorderStyle(AValue: TSwitchBorderStyle); reintroduce; procedure SetButtonSize(AValue: Integer); procedure SetCaptions(AChecked: Boolean; AValue: string); procedure SetChecked(AValue: Boolean); procedure SetColors(AIndex: Integer; AValue: TColor); procedure SetFlippedColors(AValue: Boolean); procedure SetImageIndex(AChecked: Boolean; AValue: TImageIndex); procedure SetImages(const AValue: TCustomImageList); procedure SetInverse(AValue: Boolean); procedure SetPicture(AChecked: Boolean; AValue: TPicture); procedure SetShowButtonBorder(AValue: Boolean); procedure SetShowCaption(AValue: Boolean); procedure SetShowFocusRect(AValue: Boolean); procedure UpdateButtonPos; procedure UpdateMaxDistance; procedure UpdateShape; protected function CalcButtonRect: TRect; function CalcMargin: Integer; function CanChange: Boolean; virtual; procedure DblClick; override; procedure DblClickTimerHandler(Sender: TObject); procedure DoAnimation(Sender: TObject); procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); override; procedure DoChange; virtual; procedure DoEnter; override; procedure DoExit; override; procedure DoImageListChange(Sender: TObject); function DraggedToON: Boolean; procedure DrawButton(ARect: TRect); virtual; procedure DrawCaption(ARect: TRect; AChecked: Boolean); virtual; procedure DrawFocusRect(ARect: TRect); class function GetControlClassDefaultSize: TSize; override; function HasPicture: Boolean; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override; procedure MouseMove(Shift: TShiftState; X,Y: Integer); override; function MouseOnButton(X, Y: Integer): Boolean; virtual; procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Paint; override; property Animated: Boolean read FAnimated write SetAnimated default false; property AnimationEffects: TSwitchAnimationEffects read FAnimationEffects write FAnimationEffects default [saeBlendColors, saeBlendImages]; property BorderColor: TColor index 2 read GetColors write SetColors default clGray; property BorderStyle: TSwitchBorderStyle read FBorderStyle write SetBorderStyle default bsThin; property ButtonSize: Integer read FButtonSize write SetButtonSize default DEFAULT_BUTTON_SIZE; property CaptionOFF: String index false read GetCaptions write SetCaptions; property CaptionON: String index true read GetCaptions write SetCaptions; property Checked: Boolean read FChecked write SetChecked default false; property Color default clWindow; property ColorOFF: TColor index 0 read GetColors write SetColors default clMaroon; property ColorON: TColor index 1 read GetColors write SetColors default clGreen; property FlippedColors: Boolean read FFlippedColors write SetFlippedColors default false; property ImageIndexOFF: TImageIndex index false read GetImageIndex write SetImageIndex default -1; property ImageIndexON: TImageIndex index true read GetImageIndex write SetImageIndex default -1; property Images: TCustomImageList read FImages write SetImages; property ImagesWidth: Integer read FImagesWidth write FImagesWidth default 0; property Inverse: Boolean read FInverse write SetInverse default false; property PictureOFF: TPicture index false read GetPicture write SetPicture; property PictureON: TPicture index true read GetPicture write SetPicture; property ReadOnly: boolean read FReadOnly write FReadOnly default false; property ShowButtonBorder: Boolean read FShowButtonBorder write SetShowButtonBorder default true; property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default true; property ShowCaption: Boolean read FShowCaption write SetShowCaption default true; property SwitchMode: TSwitchMode read FSwitchMode write FSwitchMode default smSlideDblClick; property OnChange: TNotifyEvent read FOnChange write FOnChange; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; property Orientation: TSwitchOrientation read GetOrientation; end; TOnOffSwitch = class(TCustomOnOffSwitch) published property Animated; property AnimationEffects; property BorderColor; property BorderStyle; property ButtonSize; property CaptionOFF; property CaptionON; property Checked; property Color; property ColorOFF; property ColorON; property Enabled; property FlippedColors; property ImageIndexON; property ImageIndexOFF; property Images; property ImagesWidth; property Inverse; property PictureOFF; property PictureON; property ReadOnly; property ShowButtonBorder; property ShowCaption; property ShowFocusRect; property SwitchMode; // inherited property Action; property Align; property Anchors; property BorderSpacing; property Constraints; property DoubleBuffered; property Font; property PopupMenu; property ShowHint; property TabOrder; property TabStop default true; property Visible; // new property OnChange; // inherited property OnChangeBounds; property OnClick; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseUp; property OnResize; property OnShowHint; end; implementation uses Math, FPImage, GraphMath, IntfGraphics; function BlendColors(AFactor: Double; AColor1, AColor2: TColor): TColor; var f1, f2: Double; r, g, b: Byte; begin f1 := 1.0 - AFactor; f2 := AFactor; r := EnsureRange(round(GetRValue(AColor1) * f1 + GetRValue(AColor2) * f2), 0, 255); g := EnsureRange(round(GetGValue(AColor1) * f1 + GetGValue(AColor2) * f2), 0, 255); b := EnsureRange(round(GetBValue(AColor1) * f1 + GetBValue(AColor2) * f2), 0, 255); Result := RGBToColor(r, g, b); end; procedure BlendImages(Img, Img1, Img2: TFPCustomImage; AFactor: Double); var x, y: Integer; r,g,b,a: Word; f1, f2: Double; begin f1 := 1.0 - AFactor; f2 := AFactor; for y := 0 to Img1.Height-1 do for x := 0 to Img1.Width-1 do begin r := round(f1 * Img1.Colors[x, y].Red + f2 * Img2.Colors[x, y].Red); g := round(f1 * Img1.Colors[x, y].Green + f2 * Img2.Colors[x, y].Green); b := round(f1 * Img1.Colors[x, y].Blue + f2 * Img2.Colors[x, y].Blue); a := round(f1 * Img1.Colors[x, y].Alpha + f2 * Img2.Colors[x, y].Alpha); Img.Colors[x, y] := FPColor(r, g, b, a); end; end; {$IF LCL_FullVersion < 3000000} function RotatePoint(const APoint: TPoint; AAngle: Double): TPoint; var sa, ca: Double; begin SinCos(AAngle, sa, ca); Result.X := Round( ca * APoint.X + sa * APoint.Y); Result.Y := Round(-sa * APoint.X + ca * APoint.Y); end; {$ENDIF} procedure RotateImage(Img: TFPCustomImage; Angle: Double); var Buffer: TFPCustomImage; x, y: Integer; C, P: TPoint; begin Buffer := TFPMemoryImage.Create(Img.Width, Img.Height); try C := Point(Img.Width div 2, Img.Height div 2); for y := 0 to Buffer.Height-1 do for x := 0 to Buffer.Width-1 do begin P := RotatePoint(Point(x, y) - C, Angle) + C; if (P.X >= 0) and (P.Y >= 0) and (P.X < Img.Width) and (P.Y < Img.Height) then Buffer.Colors[x, y] := Img.Colors[P.X, P.Y] else Buffer.Colors[x, y] := colTransparent; end; for y := 0 to Img.Height-1 do for x := 0 to Img.Width-1 do Img.Colors[x, y] := Buffer[x, y]; finally Buffer.Free; end; end; function TintedColor(AColor: TColor; ADelta: Integer): TColor; var r, g, b: Byte; begin AColor := ColorToRGB(AColor); r := GetRValue(AColor); g := GetGValue(AColor); b := GetBValue(AColor); if r + g + b < 3*128 then // Dark color --> make it brighter ADelta := abs(ADelta) else // Bright color --> make it darker ADelta := -abs(ADelta); r := EnsureRange(r + ADelta, 0, 255); g := EnsureRange(g + ADelta, 0, 255); b := EnsureRange(b + ADelta, 0, 255); Result := RGBToColor(r, g, b); end; { TOnOffSwitch } constructor TCustomOnOffSwitch.Create(AOwner: TComponent); begin inherited; TabStop := true; Color := clWindow; FAnimationEffects := [saeBlendColors, saeBlendImages]; FBorderStyle := bsThin; FButtonSize := DEFAULT_BUTTON_SIZE; FColors[0] := clMaroon; // unchecked color FColors[1] := clGreen; // checked color FColors[2] := clGray; // Border color FCaptions[false] := 'OFF'; FCaptions[true] := 'ON'; FImageListChangeLink := TChangeLink.Create; FImageListChangeLink.OnChange := @DoImageListChange; FImageIndex[false] := -1; FImageIndex[true] := -1; FPicture[false] := TPicture.Create; FPicture[true] := TPicture.Create; FShowCaption := true; FShowButtonBorder := true; FShowFocusRect := true; FSwitchMode := smSlideDblClick; FDblClickTimer := TTimer.Create(self); FDblClickTimer.Interval := 500; FDblClickTimer.Enabled := false; FDblClickTimer.OnTimer := @DblClickTimerHandler; with GetControlClassDefaultSize do SetInitialBounds(0, 0, CX, CY); end; destructor TCustomOnOffSwitch.Destroy; begin FPicture[false].Free; FPicture[true].Free; FImageListChangeLink.Free; inherited; end; function TCustomOnOffSwitch.CalcButtonRect: TRect; begin Result := FButtonRect; case Orientation of soHorizontal : OffsetRect(Result, FButtonPos + CalcMargin, 0); soVertical : OffsetRect(Result, 0, FButtonPos + CalcMargin); end; end; function TCustomOnOffSwitch.CalcMargin: Integer; begin Result := 3 + GetBorderWidth; end; function TCustomOnOffSwitch.CanChange: Boolean; begin Result := Enabled and (not FReadOnly); end; procedure TCustomOnOffSwitch.DblClick; begin inherited; FDblClickTimer.Enabled := false; if CanChange and FTogglePending then begin FTogglePending := false; SetChecked(not FChecked); end; end; procedure TCustomOnOffSwitch.DblClickTimerHandler(Sender: TObject); begin FTogglePending := true; end; procedure TCustomOnOffSwitch.DoAutoAdjustLayout( const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); begin inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion); if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then begin case Orientation of soHorizontal : FButtonSize := Round(FButtonSize * AXProportion); soVertical : FButtonSize := Round(FButtonSize * AYProportion); end; end; end; { Handler for the animation timer } procedure TCustomOnOffSwitch.DoAnimation(Sender: TObject); const SPEED = 3; begin if FCheckedAfterAnimation xor FInverse then begin inc(FButtonPos, SPEED); if FButtonPos >= FMaxDistance then begin FAnimationTimer.Enabled := false; FChecked := FCheckedAfterAnimation; UpdateButtonPos; DoChange; end; end else begin dec(FButtonPos, SPEED); if FButtonPos <= 0 then begin FAnimationTimer.Enabled := false; FChecked := FCheckedAfterAnimation; UpdateButtonPos; DoChange; end; end; Invalidate; end; procedure TCustomOnOffSwitch.DoChange; begin if Assigned(FOnChange) then FOnChange(self); end; procedure TCustomOnOffSwitch.DoEnter; begin inherited; Invalidate; end; procedure TCustomOnOffSwitch.DoExit; begin inherited; Invalidate; end; procedure TCustomOnOffSwitch.DoImageListChange(Sender: TObject); begin Invalidate; end; { Determines whether the dragged distance lands in the part of the ON (Result = true) or OFF state (Result = false) } function TCustomOnOffSwitch.DraggedToON: Boolean; begin Result := FButtonPos > FMaxDistance div 2; if FInverse then Result := not Result; end; procedure TCustomOnOffSwitch.DrawButton(ARect: TRect); var rawON, rawOFF: TRawImage; Img, ImgOn, ImgOff: TLazIntfImage; bmp: TBitmap; ImgSize: TSize; x, y: Integer; idx: Integer; ppi: Integer; begin if not Enabled then begin Canvas.Brush.Color := clGrayText; Canvas.Pen.Color := clGrayText; end else begin if FFlippedColors then Canvas.Brush.Color := Color else if (saeBlendColors in FAnimationEffects) then Canvas.Brush.Color := BlendColors(FButtonPos/FMaxDistance, ColorOFF, ColorON) else if FChecked then Canvas.Brush.Color := ColorON else Canvas.Brush.Color := ColorOFF; Canvas.Pen.Color := clBlack; end; if not FShowButtonBorder then Canvas.Pen.Color := Canvas.Brush.Color; Canvas.Pen.Width := 1; Canvas.Pen.Style := psSolid; if FBorderStyle in [bsNoneRounded, bsThinRounded, bsThickRounded] then begin dec(ARect.Bottom); dec(ARect.Right); Canvas.Ellipse(ARect); end else Canvas.Rectangle(ARect); if FImages <> nil then begin ppi := Font.PixelsPerInch; imgSize := FImages.SizeForPPI[FImagesWidth, ppi]; x := (ARect.Left + ARect.Right - imgSize.CX) div 2; y := (ARect.Top + ARect.Bottom - imgSize.CY) div 2; idx := FImageIndex[FChecked]; if idx <> -1 then begin if ([saeBlendImages, saeRotateImages] * FAnimationEffects <> []) then begin bmp := TBitmap.Create; try bmp.PixelFormat := pf32Bit; rawOFF.Init; rawON.Init; FImages.GetRawImage(FImageIndex[false], rawOFF); FImages.GetRawImage(FImageIndex[true], rawON); imgON := TLazIntfImage.Create(rawON, false); imgOFF := TLazIntfImage.Create(rawOFF, false); img := TLazIntfImage.CreateCompatible(imgOFF, imgOFF.Width, imgOFF.Height); try if saeBlendImages in FAnimationEffects then BlendImages(img, imgOFF, imgON, FButtonPos/FMaxDistance) else if FChecked then img.Assign(imgON) else img.Assign(imgOFF); if saeRotateImages in FAnimationEffects then RotateImage(img, 2*pi * FButtonPos/FMaxDistance); bmp.Assign(img); Canvas.Draw(x, y, bmp); finally img.Free; imgON.Free; imgOFF.Free; end; finally bmp.Free; end; end else FImages.DrawForPPI(Canvas, x, y, idx, FImagesWidth, ppi, GetCanvasScaleFactor, Enabled); end; end; end; procedure TCustomOnOffSwitch.DrawCaption(ARect: TRect; AChecked: Boolean); var ts: TTextStyle; begin Canvas.Font.Assign(Font); if not Enabled then Canvas.Font.Color := clGrayText; ts := Canvas.TextStyle; ts.Alignment := taCenter; ts.Layout := tlCenter; Canvas.TextStyle := ts; if AChecked then Canvas.TextRect(ARect, ARect.Left, ARect.Top, CaptionON) else Canvas.TextRect(ARect, ARect.Left, ARect.Top, CaptionOFF); end; procedure TCustomOnOffSwitch.DrawFocusRect(ARect: TRect); var m: TPenMode; c: Boolean; begin m := Canvas.Pen.Mode; c := Canvas.Pen.Cosmetic; try Canvas.Pen.Color := clBlack; Canvas.Pen.Mode := pmXOR; Canvas.Pen.Color := clWhite; Canvas.Pen.Style := psDot; Canvas.Brush.Style := bsClear; if FBorderStyle in [bsNoneRounded, bsThinRounded, bsThickRounded] then begin Canvas.Pen.Cosmetic := true; Canvas.Ellipse(ARect); end else begin Canvas.Pen.Cosmetic := false; Canvas.Rectangle(ARect); end; finally Canvas.Pen.Mode := m; Canvas.Pen.Cosmetic := c; end; end; function TCustomOnOffSwitch.GetBorderWidth: Integer; begin case FBorderStyle of bsNone, bsThin, bsThin3D, bsNoneRounded, bsThinRounded: Result := 1; bsThick, bsThick3D, bsThickRounded: Result := 2; end; end; function TCustomOnOffSwitch.GetCaptions(AChecked: Boolean): string; begin Result := FCaptions[AChecked]; end; function TCustomOnOffSwitch.GetColors(AIndex: Integer): TColor; begin Result := FColors[AIndex]; end; class function TCustomOnOffSwitch.GetControlClassDefaultSize: TSize; begin Result.CX := 60; Result.CY := 30; end; function TCustomOnOffSwitch.GetImageIndex(AChecked: Boolean): TImageIndex; begin Result := FImageIndex[AChecked]; end; function TCustomOnOffSwitch.GetOrientation: TSwitchOrientation; begin if Width > Height then Result := soHorizontal else Result := soVertical; end; function TCustomOnOffSwitch.GetPicture(AChecked: Boolean): TPicture; begin Result := FPicture[AChecked]; end; function TCustomOnOffSwitch.HasPicture: Boolean; begin Result := (FPicture[false].Width <> 0) or (FPicture[true].Width <> 0); end; procedure TCustomOnOffSwitch.KeyDown(var Key: Word; Shift: TShiftState); begin inherited; if CanChange and ((Key = VK_SPACE) or (Key = VK_RETURN)) then Checked := not Checked; end; procedure TCustomOnOffSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; SetFocus; if CanChange and (Button = mbLeft) and MouseOnButton(X, Y) then begin if (FSwitchMode in [smSlide, smSlideDblClick]) then FDragging := true; FMousePt := Point(X, Y); FDblClickTimer.Enabled := FSwitchMode in [smDblClick, smSlideDblClick]; end; end; procedure TCustomOnOffSwitch.MouseMove(Shift: TShiftState; X,Y: Integer); var delta: Integer; begin inherited; if FDragging then begin case Orientation of soHorizontal : delta := X - FMousePt.X; soVertical : delta := Y - FMousePt.Y; end; FMousePt := Point(X, Y); FButtonPos := EnsureRange(FButtonPos + delta, 0, FMaxDistance); Invalidate; end; end; function TCustomOnOffSwitch.MouseOnButton(X, Y: Integer): Boolean; var R: TRect; begin R := CalcButtonRect; Result := PtInRect(R, Point(X, Y)); end; procedure TCustomOnOffSwitch.MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); var oldChecked: Boolean; begin inherited; if (Button = mbLeft) and CanChange then begin oldChecked := FChecked; if FDragging then begin FDragging := false; FChecked := DraggedToON; UpdateButtonPos; end else begin if (FSwitchMode = smClick) or (HasPicture and (FSwitchMode = smSlide)) then SetChecked(not FChecked); if FChecked <> oldChecked then DoChange else if (FSwitchMode in [smDblClick, smSlideDblClick]) then FTogglePending := true; end; if FChecked <> oldChecked then Invalidate; end; end; procedure TCustomOnOffSwitch.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = Images) then SetImages(nil); end; procedure TCustomOnOffSwitch.Paint; var R: TRect; margin: Integer; diam: Integer; newChecked: Boolean; begin R := Rect(0, 0, Width, Height); if HasPicture then begin Canvas.StretchDraw(R, FPicture[FChecked].Graphic); exit; end; if Enabled then begin if FFlippedColors then begin if (saeBlendColors in FAnimationEffects) then Canvas.Brush.Color := BlendColors(FButtonPos/FMaxDistance, ColorOFF, ColorON) else if FChecked then Canvas.Brush.Color := ColorON else Canvas.Brush.Color := ColorOFF; end else Canvas.Brush.Color := Color; Canvas.Pen.Color := BorderColor; end else begin Canvas.Brush.Color := clInactiveBorder; Canvas.Pen.Color := clGrayText; end; Canvas.Brush.Style := bsSolid; Canvas.Pen.Style := psSolid; Canvas.Pen.Width := GetBorderWidth; case FBorderStyle of bsNone: begin Canvas.Pen.Style := psClear; Canvas.Rectangle(R); end; bsThin: Canvas.Rectangle(R); bsThick: Canvas.Rectangle(1, 1, Width, Height); bsThin3D, bsThick3D: begin Canvas.Pen.Width := 1; Canvas.Pen.Color := clBtnShadow; Canvas.Line(R.Left, R.Top, R.Right, R.Top); Canvas.Line(R.Left, R.Top, R.Left, R.Bottom); if FBorderStyle = bsThick3D then begin Canvas.Line(R.Left+1, R.Top+1, R.Right-1, R.Top+1); Canvas.Line(R.Left+1, R.Top+1, R.Left+1, R.Bottom-1); end; Canvas.Pen.Color := clBtnHighlight; Canvas.Line(R.Left, R.Bottom-1, R.Right, R.Bottom-1); Canvas.Line(R.Right-1, R.Top, R.Right-1, R.Bottom); if FBorderStyle = bsThin3D then begin InflateRect(R, -1, -1); Canvas.FillRect(R) end else begin InflateRect(R, -2, -2); Canvas.Line(R.Left-1, R.Bottom, R.Right+1, R.Bottom); Canvas.Line(R.Right, R.Top-1, R.Right, R.Bottom); Canvas.FillRect(R); end; end; bsNoneRounded, bsThinRounded, bsThickRounded: begin case FBorderStyle of bsNoneRounded: Canvas.Pen.Style := psClear; bsThickRounded: InflateRect(R, -1, -1); end; if Orientation = soHorizontal then diam := R.Height else diam := R.Width; Canvas.RoundRect(R, diam, diam); end; end; margin := CalcMargin; case Orientation of soHorizontal: FButtonRect := Rect(0, margin, FButtonSize, Height - margin); soVertical: FButtonRect := Rect(margin, 0, Width - margin, FButtonSize); end; if FShowCaption then begin if FDragging then newChecked := DraggedToOn //DraggingToON(FMovedDistance) else newchecked := FChecked; case Orientation of soHorizontal: if FChecked xor FInverse then begin // Drag begins from button at right if FDragging and not (FInverse xor newChecked) then DrawCaption(Rect(margin + FButtonSize, margin, Width, Height - margin), FInverse) else DrawCaption(Rect(0, margin, Width - margin - FButtonSize, Height - margin), not FInverse); end else begin // Drag begins from button at left if FDragging and (FInverse xor newChecked) then DrawCaption(Rect(0, margin, Width - margin - FButtonSize, Height - margin), not FInverse) else DrawCaption(Rect(margin + FButtonSize, margin, Width, Height - margin), FInverse); end; soVertical: if FChecked xor FInverse then begin // Drag begins from button at bottom if FDragging and not (FInverse xor newChecked) then DrawCaption(Rect(margin, margin + FButtonSize, Width-margin, Height), FInverse) else DrawCaption(Rect(margin, 0, Width - margin, Height - margin - FButtonSize), not FInverse); end else begin // Drag begins from button at top if FDragging and (FInverse xor newChecked) then DrawCaption(Rect(margin, 0, Width - margin, Height - margin - FButtonSize), not FInverse) else DrawCaption(Rect(margin, margin + FButtonsize, Width - margin, Height), FInverse); end; end; end; R := CalcButtonRect; DrawButton(R); if Focused and FShowFocusRect then begin InflateRect(R, 2, 2); DrawFocusRect(R); end; end; procedure TCustomOnOffSwitch.SetAnimated(AValue: Boolean); begin if AValue = FAnimated then exit; FAnimated := AValue; if FAnimated then begin if (FAnimationTimer = nil) then begin FAnimationTimer := TTimer.Create(self); FAnimationTimer.Interval := 10; FAnimationTimer.Enabled := false; FAnimationTimer.OnTimer := @DoAnimation; end end else FreeAndNil(FAnimationTimer); end; procedure TCustomOnOffSwitch.SetBorderStyle(AValue: TSwitchBorderStyle); begin if AValue = FBorderStyle then exit; FBorderStyle := AValue; UpdateShape; Invalidate; end; procedure TCustomOnOffSwitch.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; UpdateShape; UpdateMaxDistance; end; procedure TCustomOnOffSwitch.SetButtonSize(AValue: Integer); begin if (AValue = FButtonSize) and (AValue > 0) then exit; FButtonSize := AValue; UpdateMaxDistance; Invalidate; end; procedure TCustomOnOffSwitch.SetCaptions(AChecked: Boolean; AValue: String); begin if AValue = FCaptions[AChecked] then exit; FCaptions[AChecked] := AValue; Invalidate; end; procedure TCustomOnOffSwitch.SetChecked(AValue: Boolean); begin if AValue = FChecked then exit; if FDblClickTimer.Enabled then exit; if FAnimated then begin case Orientation of soHorizontal: FMaxDistance := Width - FButtonSize - 2*CalcMargin; soVertical: FMaxDistance := Height - FButtonSize - 2*CalcMargin; end; FAnimationTimer.Enabled := true; FCheckedAfterAnimation := AValue; end else begin FChecked := AValue; UpdateButtonPos; DoChange; Invalidate; end; end; procedure TCustomOnOffSwitch.SetColors(AIndex: Integer; AValue: TColor); begin if AValue = FColors[AIndex] then exit; FColors[AIndex] := AValue; Invalidate; end; procedure TCustomOnOffSwitch.SetFlippedColors(AValue: Boolean); begin if AValue = FFlippedColors then exit; FFlippedColors := AValue; Invalidate; end; procedure TCustomOnOffSwitch.SetImageIndex(AChecked: Boolean; AValue: TImageIndex); begin if FImageIndex[AChecked] = AValue then Exit; FImageIndex[AChecked] := AValue; Invalidate; end; procedure TCustomOnOffSwitch.SetImages(const AValue: TCustomImageList); begin if FImages = AValue then Exit; if FImages <> nil then begin FImages.UnRegisterChanges(FImageListChangeLink); FImages.RemoveFreeNotification(Self); end; FImages := AValue; if FImages <> nil then begin FImages.FreeNotification(Self); FImages.RegisterChanges(FImageListChangeLink); end; DoImageListChange(Self); end; procedure TCustomOnOffSwitch.SetInverse(AValue: boolean); begin if AValue = FInverse then exit; FInverse := AValue; UpdateButtonPos; Invalidate; end; procedure TCustomOnOffSwitch.SetPicture(AChecked: Boolean; AValue: TPicture); begin if AValue = FPicture[AChecked] then exit; if AValue = nil then FPicture[AChecked].Clear else FPicture[AChecked].Assign(AValue); Invalidate; end; procedure TCustomOnOffSwitch.SetShowButtonBorder(AValue: Boolean); begin if AValue = FShowButtonBorder then exit; FShowButtonBorder := AValue; DoChange; Invalidate; end; procedure TCustomOnOffSwitch.SetShowCaption(AValue: Boolean); begin if AValue = FShowCaption then exit; FShowCaption := AValue; DoChange; Invalidate; end; procedure TCustomOnOffSwitch.SetShowFocusRect(AValue: Boolean); begin if AValue = FShowFocusRect then exit; FShowFocusRect := AValue; DoChange; Invalidate; end; procedure TCustomOnOffSwitch.UpdateButtonPos; begin if FChecked xor FInverse then FButtonPos := FMaxDistance else FButtonPos := 0; end; procedure TCustomOnOffSwitch.UpdateMaxDistance; begin case Orientation of soHorizontal: FMaxDistance := Width - FButtonSize - 2*CalcMargin; soVertical: FMaxDistance := Height - FButtonSize - 2*CalcMargin; end; UpdateButtonPos; end; procedure TCustomOnOffSwitch.UpdateShape; var R: TRect; bmp: TBitmap; diam: Integer; begin R := Rect(0, 0, Width, Height); bmp := TBitmap.Create; try bmp.Monochrome := true; bmp.SetSize(R.Width, R.Height); if FBorderStyle in [bsNoneRounded, bsThinRounded, bsThickRounded] then begin if Orientation = soHorizontal then diam := R.Height else diam := R.Width; bmp.Canvas.Brush.Color := clBlack; bmp.Canvas.FillRect(R); bmp.Canvas.Brush.Color := clWhite; // bmp.Canvas.Pen.Style := psClear; bmp.Canvas.Pen.Color := clWhite; bmp.Canvas.Pen.Width := GetBorderWidth; if FBorderStyle = bsThickRounded then InflateRect(R, -1, -1); bmp.Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, diam, diam); end else begin bmp.Canvas.Brush.Color := clWhite; bmp.Canvas.FillRect(R); end; SetShape(bmp); finally bmp.Free; end; end; end.