ZoomControl.pas

unit ZoomControl;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, Themes,
  UxTheme, Graphics;

type
  TZoomFunction = reference to function(const Value: Double): Double;
  TZoomControl = class;
  TGetZoomLabelEvent = procedure(ZoomControl: TZoomControl;
    const AZoomLevel: Double; var ALabel: string) of object;
  TZoomControl = class(TCustomControl)
  private
    type
      TPointWhere = (pwNowhere, pwLabel, pwMinus, pwBeforeThumb, pwThumb, pwAfterThumb, pwPlus);
      TState = (sNull, sThumbHover, sMinusHover, sPlusHover, sThumbDown,
                sMinusDown, sPlusDown, sLabelHover, sLabelDown);
      TFocusControl = (fcLabel, fcMinus, fcTrackBar, fcPlus);
  private
    FTrackRect, FThumbRect, FLabelRect, FPlusRect, FMinusRect: TRect;
    FTextSize, FButtonSize, FVertSpace, FHortzSpace, FThumbWidth,
      FTrackHeight: Integer;
    FZoomLevel: Double;
    FZoomMin: Double;
    FZoomMax: Double;
    FInitialZoom: Double;
    FShowLabel: Boolean;
    FFont: TFont;
    FStep: Integer;
    FMouseDown: Boolean;
    FState: TState;
    FFocusControl: TFocusControl;
    FText: string;
    FLinearScale: Boolean;
    FOnChange: TNotifyEvent;
    FOnGetZoomLabel: TGetZoomLabelEvent;
    FFactorToLevelFcn,
    FLevelToFactorFcn: TZoomFunction;
    FLabelWidth: Integer;
    procedure SetZoomLevel(const ZoomLevel: Double);
    procedure SetZoomMin(const ZoomMin: Double);
    procedure SetZoomMax(const ZoomMax: Double);
    procedure SetShowLabel(ShowLabel: Boolean);
    procedure SetFont(Font: TFont);
    procedure SetFocusControl(FocusControl: TFocusControl);
    procedure SetButtonSize(ButtonSize: Integer);
    function GetZoomFractionalPosition: Real;
    function FracScale(const AWidth: Integer; const AFraction: Real): Integer; inline;
    procedure UpdateMetrics;
    function GetMouseWhere(const X, Y: Integer): TPointWhere;
    procedure SetState(State: TState);
    procedure SetStateAndFocusControl(State: TState; FocusControl: TFocusControl);
    function DisplayDialog: Boolean;
    procedure FontChange(Sender: TObject);
    procedure DecZoom(Amnt: Integer = 0);
    procedure IncZoom(Amnt: Integer = 0);
    function GetZoomFromClientX(const X: Integer): Double;
    procedure SetLinearScale(ALinearScale: Boolean);
    procedure DoGetLabel;
    procedure SetLabelWidth(ALabelWidth: Integer);
  protected
    procedure Paint; override;
    procedure WndProc(var Message: TMessage); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseLeave(Sender: TObject);
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateZoomLevelSilently(ZoomLevel: Integer);
    property FactorToLevelFcn: TZoomFunction read FFactorToLevelFcn write FFactorToLevelFcn;
    property LevelToFactorFcn: TZoomFunction read FLevelToFactorFcn write FLevelToFactorFcn;
  published
    property Align;
    property Anchors;
    property Margins;
    property AlignWithMargins;
    property Padding;
    property Cursor;
    property Color;
    property ButtonSize: Integer read FButtonSize write SetButtonSize default 24;
    property LabelWidth: Integer read FLabelWidth write SetLabelWidth default 40;
    property LinearScale: Boolean read FLinearScale write SetLinearScale default False;
    property ZoomLevel: Double read FZoomLevel write SetZoomLevel;
    property InitialZoom: Double read FInitialZoom write FInitialZoom;
    property ZoomMin: Double read FZoomMin write SetZoomMin;
    property ZoomMax: Double read FZoomMax write SetZoomMax;
    property ShowLabel: Boolean read FShowLabel write SetShowLabel default True;
    property Font: TFont read FFont write SetFont;
    property Step: Integer read FStep write FStep default 10;
    property ShowHint default True;
    property TabStop;
    property TabOrder;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnGetZoomLabel: TGetZoomLabelEvent read FOnGetZoomLabel write FOnGetZoomLabel;
  end;

procedure Register;

implementation

uses Math, Dialogs, MultiInput;

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TZoomControl]);
end;

{ TZoomControl }

constructor TZoomControl.Create(AOwner: TComponent);
begin
  inherited;
  FState := sNull;
  FZoomLevel := 100;
  FInitialZoom := 100;
  FZoomMin := 0;
  FZoomMax := 500;
  FShowLabel := True;
  FLabelWidth := 40;
  FFont := TFont.Create;
  FFont.Assign(Screen.HintFont);
  FFont.OnChange := FontChange;
  FStep := 10;
  FFocusControl := fcTrackBar;
  OnMouseLeave := MouseLeave;
  FButtonSize := 24;
  ShowHint := True;
end;

procedure TZoomControl.FontChange(Sender: TObject);
begin
  UpdateMetrics;
  Repaint;
end;

function TZoomControl.GetZoomFractionalPosition: Real;
begin

  if FLinearScale then
    Result := (FZoomLevel - FZoomMin) / (FZoomMax - FZoomMin)
  else
    if FZoomLevel <= 100 then
      Result := FZoomLevel / 200
    else
      Result := 0.5 + (FZoomLevel - 100) / (2*(FZoomMax-100));

end;

function TZoomControl.FracScale(const AWidth: Integer; const AFraction: Real): Integer;
begin
  Result := Round(AWidth * AFraction);
end;

function TZoomControl.GetZoomFromClientX(const X: Integer): Double;
var
  FractionalPos: Double;
begin

  FractionalPos := (X - FTrackRect.Left) / FTrackRect.Width;

  if FLinearScale then
    Result := 100 * FractionalPos
  else
    if FractionalPos <= 0.5 then
      Result := FractionalPos * 200
    else
      Result := 100 + (2*(FractionalPos - 0.5) * (FZoomMax - 100));

  Result := EnsureRange(Result, FZoomMin, FZoomMax);

end;

procedure TZoomControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FMouseDown := True;
  case GetMouseWhere(X, Y) of
    pwNowhere: SetState(sNull);
    pwLabel: SetStateAndFocusControl(sLabelDown, fcLabel);
    pwMinus: SetStateAndFocusControl(sMinusDown, fcMinus);
    pwBeforeThumb:
      SetStateAndFocusControl(sNull, fcTrackBar);
    pwThumb:
      SetStateAndFocusControl(sThumbDown, fcTrackBar);
    pwAfterThumb:
      SetStateAndFocusControl(sNull, fcTrackBar);
    pwPlus: SetStateAndFocusControl(sPlusDown, fcPlus);
  end;
end;

procedure TZoomControl.MouseLeave(Sender: TObject);
begin
  if not FMouseDown then
    SetState(sNull);
end;

procedure TZoomControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  case FState of
    sNull: ;
    sThumbHover: ;
    sMinusHover: ;
    sPlusHover: ;
    sThumbDown:
      begin
        SetZoomLevel(GetZoomFromClientX(X));
        Exit;
      end;
    sMinusDown: ;
    sPlusDown: ;
    sLabelHover: ;
    sLabelDown: ;
  end;

  if not FMouseDown then
    case GetMouseWhere(X, Y) of
      pwNowhere: SetState(sNull);
      pwLabel: SetState(sLabelHover);
      pwMinus: SetState(sMinusHover);
      pwBeforeThumb:
        begin
          SetState(sNull);
        end;
      pwThumb: SetState(sThumbHover);
      pwAfterThumb:
        begin
          SetState(sNull);
        end;
      pwPlus: SetState(sPlusHover);
    end;
end;

procedure TZoomControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FMouseDown := False;
  case FState of
    sNull:
      case GetMouseWhere(X, Y) of
        pwBeforeThumb: DecZoom;
        pwAfterThumb: IncZoom;
      end;
    sThumbHover: ;
    sMinusHover: ;
    sMinusDown:
      if GetMouseWhere(X, Y) = pwMinus then
        DecZoom;
    sPlusHover: ;
    sPlusDown:
      if GetMouseWhere(X, Y) = pwPlus then
        IncZoom;
    sLabelHover: ;
    sLabelDown:
      if GetMouseWhere(X, Y) = pwLabel then
        if Button = mbLeft then
          SetZoomLevel(FInitialZoom)
        else
          DisplayDialog;
  end;
  SetState(sNull);
end;

function PointInRect(X, Y: Integer; R: TRect): Boolean;
begin
  Result := InRange(X, R.Left, R.Right) and InRange(Y, R.Top, R.Bottom);
end;

function TZoomControl.GetMouseWhere(const X, Y: Integer): TPointWhere;
begin
  if PointInRect(X, Y, FLabelRect) and FShowLabel then
    Exit(pwLabel)
  else if PointInRect(X, Y, FMinusRect) then
    Exit(pwMinus)
  else if PointInRect(X, Y, FPlusRect) then
    Exit(pwPlus)
  else if PointInRect(X, Y, FThumbRect) then
    Exit(pwThumb)
  else if PointInRect(X, Y, FTrackRect) then
  begin
    if X < FThumbRect.Left then
      Exit(pwBeforeThumb)
    else
      Exit(pwAfterThumb);
  end
  else
    Exit(pwNowhere);
end;

destructor TZoomControl.Destroy;
begin
  FFont.Free;
  inherited;
end;

procedure TZoomControl.Paint;
var
  details: TThemedElementDetails;
const
  FTextFlags = DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOCLIP;
begin
  inherited;

  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(ClientRect);

  if ThemeServices.ThemesEnabled then
  begin

    with details do
    begin
      Element := teTrackBar;
      Part := TKP_TRACK;
      State := TRS_NORMAL;
    end;
    ThemeServices.DrawElement(Canvas.Handle, details, FTrackRect);

    with details do
    begin
      Element := teTrackBar;
      Part := TKP_THUMBBOTTOM;
      case FState of
        sThumbHover: State := TUBS_HOT;
        sThumbDown: State := TUBS_PRESSED;
      else
        State := TUBS_NORMAL;
      end;
      if Focused and (FFocusControl = fcTrackBar) then
        State := PBS_HOT;
    end;
    ThemeServices.DrawElement(Canvas.Handle, details, FThumbRect);

  end
  else
  begin

    DrawEdge(Canvas.Handle, FTrackRect, EDGE_SUNKEN, BF_RECT);

    case FState of
      sThumbHover:
        DrawEdge(Canvas.Handle, FThumbRect, EDGE_RAISED, BF_RECT);
      sThumbDown:
        DrawEdge(Canvas.Handle, FThumbRect, EDGE_SUNKEN, BF_RECT);
    else
      DrawEdge(Canvas.Handle, FThumbRect, EDGE_ETCHED, BF_RECT);
    end;

  end;

  Canvas.Brush.Style := bsClear;

  if FShowLabel then
  begin
    InflateRect(FLabelRect, 2, 2);
    case FState of
      sLabelHover:
        DrawEdge(Canvas.Handle, FLabelRect, EDGE_RAISED, BF_RECT);
      sLabelDown:
        DrawEdge(Canvas.Handle, FLabelRect, EDGE_SUNKEN, BF_RECT);
    end;
    InflateRect(FLabelRect, -2, -2);
    DrawTextEx(Canvas.Handle, PChar(FText), FText.Length, FLabelRect, FTextFlags, nil);
  end;

  with details do
  begin
    Element := teButton;
    Part := BP_PUSHBUTTON;
    case FState of
      sMinusHover: State := PBS_HOT;
      sMinusDown: State := PBS_PRESSED;
    else
      State := PBS_NORMAL;
    end;
    if Focused and (FFocusControl = fcMinus) then
      State := PBS_HOT;
  end;
  ThemeServices.DrawElement(Canvas.Handle, details, FMinusRect);
  DrawTextEx(Canvas.Handle, '−', 1, FMinusRect, FTextFlags, nil);

  with details do
  begin
    Element := teButton;
    Part := BP_PUSHBUTTON;
    case FState of
      sPlusHover: State := PBS_HOT;
      sPlusDown: State := PBS_PRESSED;
    else
      State := PBS_NORMAL;
    end;
    if Focused and (FFocusControl = fcPlus) then
      State := PBS_HOT;
  end;
  ThemeServices.DrawElement(Canvas.Handle, details, FPlusRect);
  DrawTextEx(Canvas.Handle, '+', 1, FPlusRect, FTextFlags, nil);

  if Focused then
    case FFocusControl of
      fcLabel:
        if ShowLabel and (FState <> sLabelDown) then
        begin
          InflateRect(FLabelRect, 2, 2);
          DrawEdge(Canvas.Handle, FLabelRect, EDGE_RAISED, BF_RECT);
          InflateRect(FLabelRect, +2, +2);
        end;
      fcMinus:
        DrawFocusRect(Canvas.Handle, FMinusRect);
      fcTrackBar:
        DrawFocusRect(Canvas.Handle, FTrackRect);
      fcPlus:
        DrawFocusRect(Canvas.Handle, FPlusRect);
    end;

end;

procedure TZoomControl.SetButtonSize(ButtonSize: Integer);
begin
  if FButtonSize <> ButtonSize then
  begin
    FButtonSize := ButtonSize;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.SetFocusControl(FocusControl: TFocusControl);
begin
  if FFocusControl <> FocusControl then
  begin
    FFocusControl := FocusControl;
    Invalidate;
  end;
end;

procedure TZoomControl.SetFont(Font: TFont);
begin
  FFont.Assign(Font);
end;

procedure TZoomControl.SetLabelWidth(ALabelWidth: Integer);
begin
  if FLabelWidth <> ALabelWidth then
  begin
    FLabelWidth := ALabelWidth;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.SetLinearScale(ALinearScale: Boolean);
begin
  if FLinearScale <> ALinearScale then
  begin
    FLinearScale := ALinearScale;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.SetShowLabel(ShowLabel: Boolean);
begin
  if FShowLabel <> ShowLabel then
  begin
    FShowLabel := ShowLabel;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.SetState(State: TState);
begin
  if FState <> State then
  begin
    FState := State;
    Repaint;
  end;

  // Hint management
  case State of
    sNull: Hint := '';
    sThumbHover: Hint := '';
    sMinusHover: Hint := '';
    sPlusHover: Hint := '';
    sThumbDown: Hint := '';
    sMinusDown: Hint := '';
    sPlusDown: Hint := '';
    sLabelHover: Hint := 'Click to set zoom level to 100 %.'#13#10'Right-click to set a custom zoom level.';
    sLabelDown: Hint := '';
  end;

  if Hint = '' then
    Application.HideHint;
end;

procedure TZoomControl.SetStateAndFocusControl(State: TState;
  FocusControl: TFocusControl);
begin
  if (FState <> State) or (FFocusControl <> FocusControl) then
  begin
    FState := State;
    FFocusControl := FocusControl;
    Invalidate;
  end;
end;

procedure TZoomControl.SetZoomLevel(const ZoomLevel: Double);
begin
  if FZoomLevel <> ZoomLevel then
  begin
    FZoomLevel := ZoomLevel;
    UpdateMetrics;
    Invalidate;
    if Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TZoomControl.SetZoomMax(const ZoomMax: Double);
begin
  if FZoomMax <> ZoomMax then
  begin
    FZoomMax := ZoomMax;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.SetZoomMin(const ZoomMin: Double);
begin
  if FZoomMin <> ZoomMin then
  begin
    FZoomMin := ZoomMin;
    UpdateMetrics;
    Invalidate;
  end;
end;

procedure TZoomControl.WndProc(var Message: TMessage);
begin
  inherited;
  case Message.Msg of
    WM_GETDLGCODE:
      Message.Result := Message.Result or DLGC_WANTTAB or DLGC_WANTARROWS or DLGC_WANTALLKEYS;
    WM_SIZE:
      UpdateMetrics;
  end;
end;

procedure TZoomControl.UpdateMetrics;
var
  ThumbCentrePos, ThumbPhysPos: Integer;
begin

  if Parent = nil then
    Exit;

  if GetParentForm(Self) = nil then
    Exit;

  FTextSize := IfThen(FShowLabel, FLabelWidth, 0);
  FVertSpace := 2;
  FHortzSpace := 2;
  FTrackHeight := 4;
  FTrackRect := Rect(
    FTextSize + FButtonSize + IfThen(FShowLabel, 3, 2)*FHortzSpace,
    (ClientHeight - FTrackHeight) div 2,
    ClientWidth - FButtonSize - FHortzSpace,
    (ClientHeight + FTrackHeight) div 2
  );
  FThumbWidth := 16;
  ThumbCentrePos := FTrackRect.Left + FracScale(FTrackRect.Width, GetZoomFractionalPosition);
  ThumbPhysPos := ThumbCentrePos - FThumbWidth div 2;
  FThumbRect := Rect(
    ThumbPhysPos,
    FVertSpace,
    ThumbPhysPos + FThumbWidth,
    ClientHeight - FVertSpace
  );

  Canvas.Font := Font;

  if FShowLabel then
  begin
    DoGetLabel;
    with FLabelRect, Canvas.TextExtent(FText) do
    begin
      Left := FHortzSpace;
      Top := (ClientHeight - cy) div 2;
      Right := Left + FTextSize;
      Bottom := (ClientHeight + cy) div 2;
    end;
  end;

  FMinusRect := Rect(
    IfThen(FShowLabel, 2, 1)*FHortzSpace + IfThen(FShowLabel, FLabelRect.Width),
    (ClientHeight - FButtonSize) div 2,
    IfThen(FShowLabel, 2, 1)*FHortzSpace + IfThen(FShowLabel, FLabelRect.Width) + FButtonSize,
    (ClientHeight + FButtonSize) div 2
  );
  FPlusRect := Rect(
    ClientWidth - FHortzSpace - FButtonSize,
    (ClientHeight - FButtonSize) div 2,
    ClientWidth - FHortzSpace,
    (ClientHeight + FButtonSize) div 2
  );
end;

procedure TZoomControl.UpdateZoomLevelSilently(ZoomLevel: Integer);
begin
  if FZoomLevel <> ZoomLevel then
  begin
    FZoomLevel := ZoomLevel;
    UpdateMetrics;
    Repaint;
  end;
end;

function TZoomControl.DisplayDialog: Boolean;
var
  v: Integer;
  fv: Real;
begin

  if Assigned(FLevelToFactorFcn) and Assigned(FFactorToLevelFcn) then
  begin
    fv := RoundTo(FLevelToFactorFcn(ZoomLevel), -2);
    Result := TMultiInputBox.FloatInputBox(GetParentForm(Self), 'Zoom',
      'Please enter the zoom level:', fv, FLevelToFactorFcn(FZoomMin),
      FLevelToFactorFcn(FZoomMax));
    if Result then
      SetZoomLevel(FFactorToLevelFcn(fv));
    Exit;
  end;

  v := Round(ZoomLevel);
  Result := TMultiInputBox.NumInputBox(GetParentForm(Self), 'Zoom',
    'Please enter the zoom level:', v, 10, 500);
  if Result then
    SetZoomLevel(v);

end;

procedure TZoomControl.DoGetLabel;
begin
  FText := Round(FZoomLevel).ToString + '%';
  if Assigned(FOnGetZoomLabel) then
    FOnGetZoomLabel(Self, FZoomLevel, FText);
end;

procedure TZoomControl.DecZoom(Amnt: Integer = 0);
var
  ReqZoom: Double;
begin
  ReqZoom := Max(FZoomLevel - IfThen(Amnt = 0, FStep, Amnt), FZoomMin);
  SetZoomLevel(ReqZoom);
end;

procedure TZoomControl.IncZoom(Amnt: Integer = 0);
var
  ReqZoom: Double;
begin
  ReqZoom := Min(FZoomLevel + IfThen(Amnt = 0, FStep, Amnt), FZoomMax);
  SetZoomLevel(ReqZoom);
end;

procedure TZoomControl.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case FFocusControl of
    fcLabel:
      case Key of
        VK_SPACE: DisplayDialog;
        VK_TAB:
          if ssShift in Shift then
            SetFocusControl(fcPlus)
          else
            SetFocusControl(fcMinus);
      end;
    fcMinus:
      case Key of
        VK_SPACE: DecZoom;
        VK_TAB:
          if ssShift in Shift then
            SetFocusControl(fcLabel)
          else
            SetFocusControl(fcTrackBar);
      end;
    fcTrackBar:
      case Key of
        VK_LEFT, VK_DOWN: DecZoom(1);
        VK_RIGHT, VK_UP: IncZoom(1);
        VK_PRIOR: IncZoom;
        VK_NEXT: DecZoom;
        VK_HOME: SetZoomLevel(FZoomMin);
        VK_END: SetZoomLevel(FZoomMax);
        VK_SPACE, VK_DELETE: SetZoomLevel(FInitialZoom);
        VK_TAB:
          if ssShift in Shift then
            SetFocusControl(fcMinus)
          else
            SetFocusControl(fcPlus);
      end;
    fcPlus:
      case Key of
        VK_SPACE: IncZoom;
        VK_TAB:
          if ssShift in Shift then
            SetFocusControl(fcTrackBar)
          else
            SetFocusControl(fcLabel);
      end;
  end;
end;

procedure TZoomControl.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited;

end;

end.