ImageViewer.pas

File name
C:\Users\Andreas Rejbrand\Documents\Dev\AlgoSim\Client\Controls\ImageViewer.pas
Date exported
Time exported
Formatting processor
TPascalFormattingProcessor
unit ImageViewer;

interface

uses
  Windows, Messages, SysUtils, Types, Classes, UITypes, Graphics, Controls,
  Forms, Menus, ComCtrls, ZoomControl, AppEvnts;

type
  TZoomMode = (zmProportionalFit, zmStretchFit, zmProportionalShrinkFit, zmFixed);

  TImageViewer = class(TCustomControl)
  strict private
  const
    LineSize = 10;
    MinZoom = 0.01;
    MaxZoom = 1000;
  var
    FBitmap: TBitmap;
    FZoom: Double;
    FScrollPos: TPoint;
    FZoomMode: TZoomMode;
    FDragPos: TPoint;
    FContextMenu: TPopupMenu;
    FmiProportionalShrinkFit,
    FmiProportionalFit,
    FmiStretchFit,
    FmiFixed,
    FmiZoomIn,
    FmiZoomOut,
    FmiCopy,
    FmiSaveAs,
    FmiNewWindow,
    FmiFullscreen,
    FmiExitFullscreen,
    FmiShowStatusbar,
    FmiSetBackground: TMenuItem;
    FOnZoomChange: TNotifyEvent;
    FOnZoomChangeDyn: TNotifyEvent;
    FOnBitmapChanged: TNotifyEvent;
    procedure SetBitmap(ABitmap: TBitmap);
    procedure SetZoom(const AZoom: Double); overload;
    procedure SetZoom(const AZoom: Double; const ACentre: TPoint); overload;
    procedure UpdateScrollbars;
    function GetZoomedSize: TSize;
    function GetZoomedHeight: Integer;
    function GetZoomedWidth: Integer;
    function GetImageRect: TRect;
    procedure SetScrollPosY(NewY: Integer);
    procedure SetScrollPosX(NewX: Integer);
    procedure SetScrollPosXY(NewX, NewY: Integer);
    procedure SanitizeScrollPos;
    procedure SetZoomMode(AZoomMode: TZoomMode);
    function NeedsScrolling: Boolean;
    procedure UpdateCursor;
    procedure MiSetZoomMode(Sender: TObject);
    procedure ContextPopup(Sender: TObject);
    procedure CopyToClipboard(Sender: TObject);
    procedure SaveAs(Sender: TObject);
    procedure DoZoomChange;
    procedure DoZoomChangeDyn;
    procedure DoBitmapChanged(Sender: TObject);
    procedure NewWindow(Sender: TObject);
    procedure DisplayFullscreen(Sender: TObject);
    procedure ExitFullscreen(Sender: TObject);
    function IsFullscreen: Boolean;
    function IsMainControlOnForm: Boolean;
    procedure ToggleStatusbar(Sender: TObject);
    procedure SetBackground(Sender: TObject);
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;    
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
      override;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
      override;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    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 WMMouseHWheel(var Message: TWMMouseWheel); message WM_MOUSEHWHEEL;
    procedure WndProc(var Message: TMessage); override;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure WMContextMenu(var Message: TWMContextMenu);
      message WM_CONTEXTMENU;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ZoomIn(Sender: TObject); overload;
    procedure ZoomIn(const ACentre: TPoint); overload;
    procedure ZoomOut(Sender: TObject); overload;
    procedure ZoomOut(const ACentre: TPoint); overload;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Caption;
    property Color;
    property Constraints;
    property Ctl3D;
    property DockSite;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ImageRect: TRect read GetImageRect;
    property Padding;
    property ParentBackground;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Touch;
    property Visible;
    property StyleElements;
    property Zoom: Double read FZoom write SetZoom;
    property ZoomMode: TZoomMode read FZoomMode write SetZoomMode;
    property ZoomedSize: TSize read GetZoomedSize;
    property ZoomedHeight: Integer read GetZoomedHeight;
    property ZoomedWidth: Integer read GetZoomedWidth;
    property OnAlignInsertBefore;
    property OnAlignPosition;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDockDrop;
    property OnDockOver;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnGetSiteInfo;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
    property OnBitmapChanged: TNotifyEvent read FOnBitmapChanged write FOnBitmapChanged;
    property OnZoomChange: TNotifyEvent read FOnZoomChange write FOnZoomChange;
    property OnZoomChangeDyn: TNotifyEvent read FOnZoomChangeDyn write FOnZoomChangeDyn;
  end;

  TImageViewerGUI = class(TCustomControl)
  strict private
  const
    STATUS_MESSAGE = 0;
    STATUS_SIZE = 1;
    STATUS_ZOOM_CONTROL = 2;
  var
    FImageViewer: TImageViewer;
    FStatusBar: TStatusBar;
    FZoomControl: TZoomControl;
    FAppEvents: TApplicationEvents;
    procedure StatusBarResize(Sender: TObject);
    procedure StatusBarDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel;
      const Rect: TRect);
    function GetSizeGripSize: Integer;
    procedure ImageZoomChange(Sender: TObject);
    procedure ZoomControlChange(Sender: TObject);
    procedure ZoomControlGetLabel(ZoomControl: TZoomControl;
      const AZoomLevel: Double; var ALabel: string);
    function ZoomLevelToFactor(const ALevel: Double): Double;
    function ZoomFactorToLevel(const AFactor: Double): Double;
    procedure BitmapChanged(Sender: TObject);
    procedure AppHint(Sender: TObject);
  protected
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Color;
    property Constraints;
    property Ctl3D;
    property DockSite;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ImageViewer: TImageViewer read FImageViewer;
    property Padding;
    property ParentBackground;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property StatusBar: TStatusBar read FStatusBar;
    property TabOrder;
    property TabStop;
    property Touch;
    property Visible;
    property StyleElements;
    property OnAlignInsertBefore;
    property OnAlignPosition;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDockDrop;
    property OnDockOver;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnGetSiteInfo;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

procedure Register;

const
  IMGVIEW_CURSOR_BASE = 20;
  crHand = TCursor(IMGVIEW_CURSOR_BASE + 1);
  crHandHold = TCursor(IMGVIEW_CURSOR_BASE + 2);

implementation

{$R ImageViewerCursors.res}

uses
  Math, Clipbrd, ASPixmap, IOUtils, ColorDialog;

function _scale(X: Integer): Integer;
begin
  Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;

function SanitizeFileName(const AFileName: string): string;
var
  i, c: Integer;
begin
  SetLength(Result, AFileName.Length);
  c := 0;
  for i := 1 to AFileName.Length do
    if TPath.IsValidFileNameChar(AFileName[i]) then
    begin
      Inc(c);
      Result[c] := AFileName[i];
    end;
  SetLength(Result, c);
end;

{ TImageViewer }

procedure TImageViewer.CMMouseEnter(var Message: TMessage);
begin
  UpdateCursor;
  inherited;
end;

procedure TImageViewer.ContextPopup(Sender: TObject);
var
  IsFullscreen: Boolean;
begin

  IsFullscreen := Self.IsFullscreen;

  FmiProportionalShrinkFit.Enabled := Assigned(FBitmap);
  FmiProportionalFit.Enabled := Assigned(FBitmap);
  FmiStretchFit.Enabled := Assigned(FBitmap);
  FmiFixed.Enabled := Assigned(FBitmap);
  FmiZoomIn.Enabled := Assigned(FBitmap);
  FmiZoomOut.Enabled := Assigned(FBitmap);
  FmiCopy.Enabled := Assigned(FBitmap);
  FmiSaveAs.Enabled := Assigned(FBitmap);
  FmiNewWindow.Enabled := Assigned(FBitmap);
  FmiFullscreen.Enabled := Assigned(FBitmap) and not IsFullscreen;
  FmiFullscreen.Visible := not IsFullscreen;
  FmiExitFullscreen.Visible := IsFullscreen;
  FmiShowStatusbar.Visible := (Parent is TImageViewerGUI) and
    (GetKeyState(VK_SHIFT) and $8000 <> 0);
  FmiShowStatusbar.Checked := (Parent is TImageViewerGUI) and
    TImageViewerGUI(Parent).StatusBar.Visible;
  FmiSetBackground.Visible := GetKeyState(VK_SHIFT) and $8000 <> 0;

  FmiProportionalShrinkFit.Checked := FZoomMode = zmProportionalShrinkFit;
  FmiProportionalFit.Checked := FZoomMode = zmProportionalFit;
  FmiStretchFit.Checked := FZoomMode = zmStretchFit;
  FmiFixed.Checked := FZoomMode = zmFixed;

end;

procedure TImageViewer.CopyToClipboard(Sender: TObject);
begin
  if Assigned(FBitmap) then
    Clipboard.Assign(FBitmap);
end;

constructor TImageViewer.Create(AOwner: TComponent);
begin

  inherited;

  FZoom := 1.0;
  FDragPos := Point(-1, -1);
  Screen.Cursors[crHand] := LoadImage(hInstance, 'HAND', IMAGE_CURSOR, 0, 0,
    LR_DEFAULTCOLOR);
  Screen.Cursors[crHandHold] := LoadImage(hInstance, 'HANDHOLD', IMAGE_CURSOR,
    0, 0, LR_DEFAULTCOLOR);

  ControlStyle := ControlStyle + [csOpaque];

  FContextMenu := TPopupMenu.Create(Self);
  FContextMenu.OnPopup := ContextPopup;

  FmiProportionalShrinkFit := TMenuItem.Create(FContextMenu);
  FmiProportionalShrinkFit.Caption := 'Proportional auto-shrink'#9'/';
  FmiProportionalShrinkFit.Hint := 'Proportionally shrinks, if necessary, the image to fit the window.';
  FmiProportionalShrinkFit.Tag := Ord(zmProportionalShrinkFit);
  FmiProportionalShrinkFit.RadioItem := True;
  FmiProportionalShrinkFit.OnClick := MiSetZoomMode;
  FContextMenu.Items.Add(FmiProportionalShrinkFit);

  FmiProportionalFit := TMenuItem.Create(FContextMenu);
  FmiProportionalFit.Caption := 'Proportional auto-fit'#9'*';
  FmiProportionalFit.Hint := 'Proportionally shrinks or magnifies the image to precisely fit the window.';
  FmiProportionalFit.Tag := Ord(zmProportionalFit);
  FmiProportionalFit.RadioItem := True;
  FmiProportionalFit.OnClick := MiSetZoomMode;  
  FContextMenu.Items.Add(FmiProportionalFit);

  FmiStretchFit := TMenuItem.Create(FContextMenu);
  FmiStretchFit.Caption := 'Stretch to fit'#9'~';
  FmiStretchFit.Hint := 'Stretches the image to precisely cover the entire window.';
  FmiStretchFit.Tag := Ord(zmStretchFit);
  FmiStretchFit.RadioItem := True;
  FmiStretchFit.OnClick := MiSetZoomMode;
  FContextMenu.Items.Add(FmiStretchFit);

  FmiFixed := TMenuItem.Create(FContextMenu);
  FmiFixed.Caption := 'Fixed zoom level';
  FmiFixed.Hint := 'Sets and keeps the zoom level at a precise value.';
  FmiFixed.Tag := Ord(zmFixed);
  FmiFixed.RadioItem := True;
  FmiFixed.OnClick := MiSetZoomMode;
  FContextMenu.Items.Add(FmiFixed);

  FContextMenu.Items.InsertNewLineAfter(FmiFixed);

  FmiZoomIn := TMenuItem.Create(FContextMenu);
  FmiZoomIn.Caption := 'Zoom in'#9'+';
  FmiZoomIn.Hint := 'Increases the zoom level.';
  FmiZoomIn.OnClick := ZoomIn;
  FContextMenu.Items.Add(FmiZoomIn);  

  FmiZoomOut := TMenuItem.Create(FContextMenu);
  FmiZoomOut.Caption := 'Zoom out'#9'-';
  FmiZoomOut.Hint := 'Decreases the zoom level.';
  FmiZoomOut.OnClick := ZoomOut;
  FContextMenu.Items.Add(FmiZoomOut);    

  FContextMenu.Items.InsertNewLineAfter(FmiZoomOut);  

  FmiCopy := TMenuItem.Create(FContextMenu);
  FmiCopy.Caption := 'Copy'#9'Ctrl+C';
  FmiCopy.Hint := 'Copies the image to clipboard.';
  FmiCopy.OnClick := CopyToClipboard;
  FContextMenu.Items.Add(FmiCopy);

  FmiSaveAs := TMenuItem.Create(FContextMenu);
  FmiSaveAs.Caption := 'Save as...'#9'Ctrl+S';
  FmiSaveAs.Hint := 'Saves the image to a file.';
  FmiSaveAs.OnClick := SaveAs;
  FContextMenu.Items.Add(FmiSaveAs);

  FmiNewWindow := TMenuItem.Create(FContextMenu);
  FmiNewWindow.Caption := 'New window'#9'Ctrl+N';
  FmiNewWindow.Hint := 'Creates a new window with this image.';
  FmiNewWindow.OnClick := NewWindow;
  FContextMenu.Items.Add(FmiNewWindow);

  FmiFullscreen := TMenuItem.Create(FContextMenu);
  FmiFullscreen.Caption := 'Fullscreen'#9'Ctrl+F';
  FmiFullscreen.Hint := 'Displays this image in a full-screen window.';
  FmiFullscreen.OnClick := DisplayFullscreen;
  FContextMenu.Items.Add(FmiFullscreen);

  FmiExitFullscreen := TMenuItem.Create(FContextMenu);
  FmiExitFullscreen.Caption := 'Exit fullscreen'#9'Esc';
  FmiExitFullscreen.Hint := 'Closes this full-screen window.';
  FmiExitFullscreen.OnClick := ExitFullscreen;
  FContextMenu.Items.Insert(0, FmiExitFullscreen);
  FContextMenu.Items.InsertNewLineAfter(FmiExitFullscreen);

  FmiShowStatusbar := TMenuItem.Create(FContextMenu);
  FmiShowStatusbar.Caption := 'Status bar';
  FmiShowStatusbar.Hint := 'Shows or hides the status bar.';
  FmiShowStatusbar.OnClick := ToggleStatusbar;
  FContextMenu.Items.Add(FmiShowStatusbar);

  FContextMenu.Items.InsertNewLineBefore(FmiShowStatusbar);

  FmiSetBackground := TMenuItem.Create(FContextMenu);
  FmiSetBackground.Caption := 'Background color...';
  FmiSetBackground.Hint := 'Sets the image viewer''s background colour.';
  FmiSetBackground.OnClick := SetBackground;
  FContextMenu.Items.Add(FmiSetBackground);
    
end;

destructor TImageViewer.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TImageViewer.DoBitmapChanged(Sender: TObject);
begin
  if Assigned(FOnBitmapChanged) then
    FOnBitmapChanged(Sender);
end;

function TImageViewer.DoMouseWheelDown(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  if FBitmap = nil then
    Exit(False);
  if (ssCtrl in Shift) or (FZoomMode = zmFixed) then
    if ssCtrl in Shift then
      ZoomOut(ScreenToClient(MousePos))
    else if ssShift in Shift then
      SetScrollPosY(FScrollPos.Y + 1)
    else
      SetScrollPosY(FScrollPos.Y + LineSize);
  Result := True;
end;

function TImageViewer.DoMouseWheelUp(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  if FBitmap = nil then
    Exit(False);
  if (ssCtrl in Shift) or (FZoomMode = zmFixed) then
    if ssCtrl in Shift then
      ZoomIn(ScreenToClient(MousePos))
    else if ssShift in Shift then
      SetScrollPosY(FScrollPos.Y - 1)
    else
      SetScrollPosY(FScrollPos.Y - LineSize);
  Result := True;
end;

procedure TImageViewer.DoZoomChange;
begin
  if Assigned(FOnZoomChange) then
    FOnZoomChange(Self);
end;

procedure TImageViewer.DoZoomChangeDyn;
begin
  if Assigned(FOnZoomChangeDyn) then
    FOnZoomChangeDyn(Self);
end;

procedure TImageViewer.ExitFullscreen(Sender: TObject);
var
  ParentForm: TCustomForm;
begin
  ParentForm := GetParentForm(Self);
  if ParentForm = nil then
    Exit;
  if ParentForm.BorderStyle <> bsNone then
    Exit;
  if not IsMainControlOnForm then
    Exit;
  ParentForm.Close;
end;

function TImageViewer.GetImageRect: TRect;
var
  S: TSize;
begin

  S := GetZoomedSize;

  Result := TRect.Create(
    Point(
      Max(0, (ClientWidth - S.cx) div 2),
      Max(0, (ClientHeight - S.cy) div 2)
    ),
    Min(S.cx, ClientWidth),
    Min(S.cy, ClientHeight)
  );

end;

function TImageViewer.GetZoomedHeight: Integer;
begin
  Result := GetZoomedSize.cy;
end;

function TImageViewer.GetZoomedSize: TSize;

  function ProportionalFit: TSize;
  var
    SelfAR, BMAR, f: Double;
    W, H: Integer;
  begin

    if (ClientWidth = 0) or (ClientHeight = 0) then
      Exit(TSize.Create(0, 0));

    SelfAR := ClientWidth / ClientHeight;
    BMAR := FBitmap.Width / FBitmap.Height;

    if SelfAR > BMAR then
    begin
      H := ClientHeight;
      f := H / FBitmap.Height;
      W := Round(FBitmap.Width * f);
    end
    else
    begin
      W := ClientWidth;
      f := W / FBitmap.Width;
      H := Round(FBitmap.Height * f);
    end;

    Result := TSize.Create(W, H);

  end;

var
  OldZoom: Double;

begin

  if (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0) then
    Exit(TSize.Create(0, 0));

  case FZoomMode of
    zmProportionalFit:
      Result := ProportionalFit;

    zmStretchFit:
      Result := ClientRect.Size;

    zmProportionalShrinkFit:
      begin
        if (FBitmap.Width <= ClientWidth) and (FBitmap.Height <= ClientHeight) then
          Result := TSize.Create(FBitmap.Width, FBitmap.Height)
        else
          Result := ProportionalFit;
      end;

    zmFixed:
      Result := TSize.Create(
          Round(FBitmap.Width * FZoom),
          Round(FBitmap.Height * FZoom)
        )
  else
    Result := TSize.Create(0, 0);
  end;

  if (FZoomMode <> zmFixed) and Assigned(FBitmap) and (FBitmap.Width <> 0) and (FBitmap.Height <> 0) then
  begin
    OldZoom := FZoom;
    FZoom := EnsureRange(
      (Result.cx / FBitmap.Width + Result.cy / FBitmap.Height) / 2,
      MinZoom,
      MaxZoom
    );
    if OldZoom <> FZoom then
      DoZoomChangeDyn;
  end;

end;

function TImageViewer.GetZoomedWidth: Integer;
begin
  Result := GetZoomedSize.cx;
end;

function TImageViewer.IsFullscreen: Boolean;
var
  ParentForm: TCustomForm;
begin
  ParentForm := GetParentForm(Self);
  Result := Assigned(ParentForm) and (ParentForm.BorderStyle = bsNone) and
    IsMainControlOnForm;
end;

function TImageViewer.IsMainControlOnForm: Boolean;
var
  Ctl: TWinControl;
begin
  Result := True;
  Ctl := Self;
  repeat
    if Ctl.Align <> alClient then
      Exit(False);
    Ctl := Ctl.Parent
  until (Ctl is TCustomForm) or (Ctl = nil);
end;

procedure TImageViewer.KeyDown(var Key: Word; Shift: TShiftState);
begin

  inherited;

  if FBitmap = nil then
    Exit;

  case Key of
    VK_UP:
      SetScrollPosY(FScrollPos.Y - LineSize);
    VK_DOWN:
      SetScrollPosY(FScrollPos.Y + LineSize);
    VK_RIGHT:
      SetScrollPosX(FScrollPos.X + LineSize);
    VK_LEFT:
      SetScrollPosX(FScrollPos.X - LineSize);
    VK_NEXT:
      SetScrollPosY(FScrollPos.Y + ClientHeight);
    VK_PRIOR:
      SetScrollPosY(FScrollPos.Y - ClientHeight);
    VK_HOME:
      if ssCtrl in Shift then
        SetScrollPosXY(0, 0)
      else
        SetScrollPosX(0);
    VK_END:
      if ssCtrl in Shift then
        SetScrollPosXY(ZoomedWidth - ClientWidth, ZoomedHeight - ClientHeight)
      else
        SetScrollPosX(ZoomedWidth - ClientWidth);
    VK_ADD, VK_OEM_PLUS:
      ZoomIn(Self);
    VK_SUBTRACT, VK_OEM_MINUS:
      ZoomOut(Self);
    VK_NUMPAD0, Ord('0'):
      Zoom := 1.0;
  end;

end;

procedure TImageViewer.KeyPress(var Key: Char);
begin

  inherited;

  if FBitmap = nil then
    Exit;

  case Key of
    '1'..'9':
      Zoom := StrToInt(Key);
    '0':
      Zoom := 1.0;
    '/':
      ZoomMode := zmProportionalShrinkFit;
    '*':
      ZoomMode := zmProportionalFit;
    '~':
      ZoomMode := zmStretchFit;
    ^C:
      CopyToClipboard(Self);
    ^S:
      SaveAs(Self);
    ^N:
      NewWindow(Self);
    ^F:
      if not IsFullscreen then
        DisplayFullscreen(Self);
  end;

end;

procedure TImageViewer.MiSetZoomMode(Sender: TObject);
begin
  if Sender is TMenuItem then
    ZoomMode := TZoomMode(TMenuItem(Sender).Tag);
end;

procedure TImageViewer.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin

  inherited;

  if CanFocus and not Focused then
    SetFocus;

  FDragPos := Point(X, Y);

  UpdateCursor;

end;

procedure TImageViewer.MouseMove(Shift: TShiftState; X, Y: Integer);
begin

  inherited;

  if csLButtonDown in ControlState then
  begin
    if FDragPos.Y <> -1 then
      SetScrollPosXY(
        FScrollPos.X - X + FDragPos.X,
        FScrollPos.Y - Y + FDragPos.Y
      );
    FDragPos := Point(X, Y);
  end;

end;

procedure TImageViewer.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FDragPos := Point(-1, -1);
  UpdateCursor;
end;

function TImageViewer.NeedsScrolling: Boolean;
begin
  Result := (FZoomMode = zmFixed) and Assigned(FBitmap) and 
    ((FZoom * FBitmap.Width >= ClientWidth) or (FZoom * FBitmap.Height >= ClientHeight));
end;

type
  TImgWnd = class
    class procedure FormClose(Sender: TObject; var Action: TCloseAction);
    class procedure FormKeyDownEscClose(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  end;

{ TImgWnd }

class procedure TImgWnd.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

class procedure TImgWnd.FormKeyDownEscClose(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Sender is TCustomForm then
    case Key of
      VK_ESCAPE:
        TCustomForm(Sender).Close;
    end;
end;

procedure TImageViewer.NewWindow(Sender: TObject);
var
  Frm: TForm;
  ImgView: TImageViewerGUI;
begin

  Frm := TForm.Create(nil);
  Frm.Color := clWhite;
  Frm.Caption := Caption;
  Frm.OnClose := TImgWnd.FormClose;
  Frm.Width := _scale(800);
  Frm.Height := _scale(600);
  ImgView := TImageViewerGUI.Create(Frm);
  ImgView.Parent := Frm;
  ImgView.Align := alClient;
  ImgView.ImageViewer.Bitmap := Bitmap;
  ImgView.ImageViewer.Caption := Caption;
  Frm.ScaleForPPI(Screen.PixelsPerInch);
  Frm.Show;

end;

type
  TFullscreenForm = class(TForm)
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
      message WM_WINDOWPOSCHANGED;
  end;

{ TFullscreenForm }

procedure TFullscreenForm.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  inherited;
  if BorderStyle = bsNone then
    BoundsRect := Screen.MonitorFromWindow(Handle, mdNearest).BoundsRect;
end;

procedure TImageViewer.DisplayFullscreen(Sender: TObject);
var
  Frm: TFullscreenForm;
  ImgView: TImageViewerGUI;
begin

  Frm := TFullscreenForm.CreateNew(nil);
  Frm.Color := clBlack;
  Frm.Caption := Caption;
  Frm.BorderStyle := bsNone;
  Frm.BoundsRect := Screen.MonitorFromWindow(Handle, mdNearest).BoundsRect;
  Frm.OnClose := TImgWnd.FormClose;
  Frm.KeyPreview := True;
  Frm.OnKeyDown := TImgWnd.FormKeyDownEscClose;
  ImgView := TImageViewerGUI.Create(Frm);
  ImgView.Parent := Frm;
  ImgView.Align := alClient;
  ImgView.ImageViewer.Bitmap := Bitmap;
  ImgView.ImageViewer.Caption := Caption;
  ImgView.StatusBar.Hide;
  Frm.ScaleForPPI(Screen.PixelsPerInch);
  Frm.Show;

end;

procedure TImageViewer.Paint;
var
  ImgRect: TRect;
  bm: TBitmap;
  s, d: PRGBQuad;
  y, x, i: Integer;
begin

  inherited;

  if (ClientWidth = 0) or (ClientHeight = 0) then
    Exit;

  if (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0) then
  begin
    Canvas.Brush.Color := Color;
    Canvas.FillRect(ClientRect);
    Exit;
  end;

  ImgRect := GetImageRect;

  ExcludeClipRect(Canvas.Handle, ImgRect.Left, ImgRect.Top, ImgRect.Right, ImgRect.Bottom);
  Canvas.Brush.Color := Color;
  Canvas.FillRect(ClientRect);
  SelectClipRgn(Canvas.Handle, 0);

  SetStretchBltMode(Canvas.Handle, COLORONCOLOR);

  case FZoomMode of
    zmProportionalFit,
    zmStretchFit,
    zmProportionalShrinkFit:
      StretchBlt(
        Canvas.Handle,
        ImgRect.Left,
        ImgRect.Top,
        ImgRect.Width,
        ImgRect.Height,
        FBitmap.Canvas.Handle,
        0,
        0,
        FBitmap.Width,
        FBitmap.Height,
        SRCCOPY
      );
    zmFixed:
      if not IsZero(FZoom) then
      begin
        bm := TBitmap.Create;
        try

          bm.PixelFormat := pf32bit;
          bm.SetSize(ImgRect.Width, ImgRect.Height);

          if FScrollPos.X < 0 then
            Exit;

          if FScrollPos.Y < 0 then
            Exit;

          if FZoom < 0 then
            Exit;

          if Trunc((bm.Height - 1 + FScrollPos.Y) / FZoom) > FBitmap.Height - 1 then
            Exit;

          if Trunc((bm.Width - 1 + FScrollPos.X) / FZoom) > FBitmap.Width - 1 then
            Exit;

          {$POINTERMATH ON}
          for y := 0 to bm.Height - 1 do
          begin
            s := FBitmap.ScanLine[Trunc((y + FScrollPos.Y) / FZoom)];
            d := bm.ScanLine[y];
            for x := 0 to bm.Width - 1 do
            begin
              i := Trunc((x + FScrollPos.X) / FZoom);
              d[x] := s[i];
            end;
          end;

          BitBlt(Canvas.Handle, ImgRect.Left, ImgRect.Top, ImgRect.Width,
            ImgRect.Height, bm.Canvas.Handle, 0, 0, SRCCOPY);

        finally
          bm.Free;
        end;
      end;
  end;

end;

procedure TImageViewer.Resize;
begin
  inherited;
  SanitizeScrollPos;
  UpdateScrollbars;
end;

procedure TImageViewer.SanitizeScrollPos;
var
  S: TSize;
begin
  S := GetZoomedSize;
  FScrollPos.X := EnsureRange(FScrollPos.X, 0, Max(0, S.cx - ClientWidth));
  FScrollPos.Y := EnsureRange(FScrollPos.Y, 0, Max(0, S.cy - ClientHeight));
end;

procedure TImageViewer.SaveAs(Sender: TObject);
var
  frm: TCustomForm;
begin

  if FBitmap = nil then
    Exit;

  frm := GetParentForm(Self);

  SaveGraphicToFile(FBitmap, frm, SanitizeFileName(Caption));

end;

procedure TImageViewer.SetBackground(Sender: TObject);
var
  Dlg: TColorDialog;
begin
  Dlg := TColorDialog.Create(Self);
  try
    Dlg.Color := Self.Color;
    if Dlg.Execute then
      Self.Color := Dlg.Color;
  finally
    Dlg.Free;
  end;
end;

procedure TImageViewer.SetBitmap(ABitmap: TBitmap);
begin

  if FBitmap = nil then
    FBitmap := TBitmap.Create;

  Caption := '';

  FBitmap.Assign(ABitmap);
  FBitmap.OnChange := DoBitmapChanged;
  FBitmap.PixelFormat := pf32bit;
  FScrollPos := TPoint.Zero;
  UpdateScrollbars;
  Invalidate;
  DoBitmapChanged(Self);

end;

procedure TImageViewer.SetScrollPosX(NewX: Integer);
var
  OldScrollPos: TPoint;
begin
  if FZoomMode <> zmFixed then
    Exit;
  OldScrollPos := FScrollPos;
  FScrollPos.X := EnsureRange(NewX, 0, Max(0, ZoomedWidth - ClientWidth));
  if FScrollPos = OldScrollPos then
    Exit;
  UpdateScrollbars;
  Invalidate;
end;

procedure TImageViewer.SetScrollPosXY(NewX, NewY: Integer);
var
  OldScrollPos: TPoint;
begin
  if FZoomMode <> zmFixed then
    Exit;
  OldScrollPos := FScrollPos;
  FScrollPos.X := EnsureRange(NewX, 0, Max(0, ZoomedWidth - ClientWidth));
  FScrollPos.Y := EnsureRange(NewY, 0, Max(0, ZoomedHeight - ClientHeight));
  if FScrollPos = OldScrollPos then
    Exit;
  UpdateScrollbars;
  Invalidate;
end;

procedure TImageViewer.SetScrollPosY(NewY: Integer);
var
  OldScrollPos: TPoint;
begin
  if FZoomMode <> zmFixed then
    Exit;
  OldScrollPos := FScrollPos;
  FScrollPos.Y := EnsureRange(NewY, 0, Max(0, ZoomedHeight - ClientHeight));
  if FScrollPos = OldScrollPos then
    Exit;
  UpdateScrollbars;
  Invalidate;
end;

procedure TImageViewer.SetZoom(const AZoom: Double);
begin
  SetZoom(AZoom, ClientRect.CenterPoint);
end;

procedure TImageViewer.SetZoom(const AZoom: Double; const ACentre: TPoint);
var
  LZoom: Double;
begin
  LZoom := EnsureRange(AZoom, MinZoom, MaxZoom);
  if not IsZero(FZoom) then
  begin
    FScrollPos.X := Round((LZoom / FZoom) * (FScrollPos.X + ACentre.X) - ACentre.X);
    FScrollPos.Y := Round((LZoom / FZoom) * (FScrollPos.Y + ACentre.Y) - ACentre.Y);
  end;
  if (FZoomMode <> zmFixed) or (FZoom <> LZoom) then
  begin
    FZoomMode := zmFixed;
    FZoom := LZoom;
    SanitizeScrollPos;
    UpdateScrollbars;
    Invalidate;
    UpdateCursor;
    DoZoomChange;
  end;
end;

procedure TImageViewer.SetZoomMode(AZoomMode: TZoomMode);
begin
  if not InRange(Ord(AZoomMode), Ord(Low(TZoomMode)), Ord(High(TZoomMode))) then
    Exit;
  if FZoomMode <> AZoomMode then
  begin
    FZoomMode := AZoomMode;
    FScrollPos := TPoint.Zero;
    UpdateScrollbars;
    Invalidate;
    UpdateCursor;
    DoZoomChange;
  end;
end;

procedure TImageViewer.ToggleStatusbar(Sender: TObject);
begin
  if Parent is TImageViewerGUI then
    with TImageViewerGUI(Parent) do
      StatusBar.Visible := not StatusBar.Visible;
end;

procedure TImageViewer.UpdateCursor;
begin
  if NeedsScrolling then
    if csLButtonDown in ControlState then
      SetCursor(Screen.Cursors[crHandHold])
    else
      Cursor := crHand
  else
    Cursor := crDefault;
end;

procedure TImageViewer.UpdateScrollbars;
var
  SI: TScrollInfo;
begin

  if (FZoomMode <> zmFixed) or (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0)
    or (ClientWidth = 0) or (ClientHeight = 0)
  then
    ShowScrollBar(Handle, SB_BOTH, False)
  else
  begin

    FillChar(SI, sizeof(SI), 0);
    SI.cbSize := sizeof(SI);
    SI.fMask := SIF_POS or SIF_RANGE or SIF_PAGE;
    SI.nPos := FScrollPos.Y;
    SI.nMin := 0;
    SI.nMax := ZoomedHeight;
    SI.nPage := ClientHeight;
    SetScrollInfo(Handle, SB_VERT, SI, True);

    FillChar(SI, sizeof(SI), 0);
    SI.cbSize := sizeof(SI);
    SI.fMask := SIF_POS or SIF_RANGE or SIF_PAGE;
    SI.nPos := FScrollPos.X;
    SI.nMin := 0;
    SI.nMax := ZoomedWidth;
    SI.nPage := ClientWidth;
    SetScrollInfo(Handle, SB_HORZ, SI, True);

  end;

end;

procedure TImageViewer.WMContextMenu(var Message: TWMContextMenu);
var
  p: TPoint;
begin

  if (Message.XPos = -1) and (Message.YPos = -1) then // menu key or Shift+F10
    with ClientToScreen(ClientRect.CenterPoint) do
      FContextMenu.Popup(x, y)
  else // RMB
  begin
    p := ScreenToClient(Message.Pos);
    if (p.X >= ClientWidth) or (p.Y >= ClientHeight) then // scrollbar context menu
    begin
      inherited;
      Exit;
    end;
    FContextMenu.Popup(Message.XPos, Message.YPos);
  end;

  Message.Result := 1;

end;

procedure TImageViewer.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TImageViewer.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := Message.Result or DLGC_WANTARROWS;
end;

procedure TImageViewer.WMHScroll(var Message: TWMHScroll);
var
  SI: TScrollInfo;
begin
  case Message.ScrollCode of
    SB_LEFT:
      SetScrollPosX(0);
    SB_RIGHT:
      SetScrollPosX(ZoomedWidth - ClientWidth);
    SB_LINELEFT:
      SetScrollPosX(FScrollPos.X - LineSize);
    SB_LINERIGHT:
      SetScrollPosX(FScrollPos.X + LineSize);
    SB_PAGELEFT:
      SetScrollPosX(FScrollPos.X - ClientWidth);
    SB_PAGERIGHT:
      SetScrollPosX(FScrollPos.X + ClientWidth);
    SB_THUMBTRACK:
      begin
        FillChar(SI, sizeof(SI), 0);
        SI.cbSize := sizeof(SI);
        SI.fMask := SIF_TRACKPOS;
        if not GetScrollInfo(Handle, SB_HORZ, SI) then Exit;
        SetScrollPosX(SI.nTrackPos);
      end;
  end;
  Message.Result := 0;
end;

//procedure TImageViewer.WMMouseHWheel(var Message: TWMMouseWheel);
//begin
//  SetScrollPosX(FScrollPos.X + Message.WheelDelta);
//  Message.Result := 0;
//end;

procedure TImageViewer.WMVScroll(var Message: TWMVScroll);
var
  SI: TScrollInfo;
begin
  case Message.ScrollCode of
    SB_TOP:
      SetScrollPosY(0);
    SB_BOTTOM:
      SetScrollPosY(ZoomedHeight - ClientHeight);
    SB_LINEUP:
      SetScrollPosY(FScrollPos.Y - LineSize);
    SB_LINEDOWN:
      SetScrollPosY(FScrollPos.Y + LineSize);
    SB_PAGEUP:
      SetScrollPosY(FScrollPos.Y - ClientHeight);
    SB_PAGEDOWN:
      SetScrollPosY(FScrollPos.Y + ClientHeight);
    SB_THUMBTRACK:
      begin
        FillChar(SI, sizeof(SI), 0);
        SI.cbSize := sizeof(SI);
        SI.fMask := SIF_TRACKPOS;
        if not GetScrollInfo(Handle, SB_VERT, SI) then Exit;
        SetScrollPosY(SI.nTrackPos);
      end;
  end;
  Message.Result := 0;
end;

procedure TImageViewer.WndProc(var Message: TMessage);
begin
//  case Message.Msg of
//    WM_MOUSEHWHEEL:
//      begin
//        SetScrollPosX(FScrollPos.X + TWMMouseWheel(Message).WheelDelta);
//        Message.Result := 0;
//      end;
//  else
    inherited;
//  end;
end;

procedure TImageViewer.ZoomIn(Sender: TObject);
begin
  Zoom := 1.1 * Zoom;
end;

procedure TImageViewer.ZoomIn(const ACentre: TPoint);
begin
  SetZoom(1.1 * Zoom, ACentre);
end;

procedure TImageViewer.ZoomOut(const ACentre: TPoint);
begin
  SetZoom(0.9 * Zoom, ACentre);
end;

procedure TImageViewer.ZoomOut(Sender: TObject);
begin
  Zoom := 0.9 * Zoom;
end;

{ TImageViewerGUI }

procedure TImageViewerGUI.AppHint(Sender: TObject);
begin
  if (Parent is TCustomForm) and (Align = alClient) and Assigned(FStatusBar) then
    FStatusBar.Panels[STATUS_MESSAGE].Text := Application.Hint;
end;

procedure TImageViewerGUI.BitmapChanged(Sender: TObject);
begin
  if Assigned(FStatusBar) then
    if Assigned(FImageViewer) and Assigned(FImageViewer.Bitmap) then
      FStatusBar.Panels[STATUS_SIZE].Text := Format('%d×%d',
        [FImageViewer.Bitmap.Width, FImageViewer.Bitmap.Height])
    else
      FStatusBar.Panels[STATUS_SIZE].Text := '';
end;

constructor TImageViewerGUI.Create(AOwner: TComponent);
begin
  inherited;
  FImageViewer := TImageViewer.Create(Self);
  FImageViewer.Parent := Self;
  FImageViewer.Align := alClient;
  FImageViewer.OnZoomChange := ImageZoomChange;
  FImageViewer.OnZoomChangeDyn := ImageZoomChange;
  FImageViewer.TabStop := True;
  FImageViewer.OnBitmapChanged := BitmapChanged;
  FStatusBar := TStatusBar.Create(Self);
  FStatusBar.Parent := Self;
  FStatusBar.Align := alBottom;
  FStatusBar.DoubleBuffered := True;
  FStatusBar.Height := 24;
  FStatusBar.Panels.Add;
  with FStatusBar.Panels.Add do
  begin
    Alignment := taCenter;
    Width := 100;
  end;
  with FStatusBar.Panels.Add do
  begin
    Style := psOwnerDraw;
    Width := 200;
  end;
  FStatusBar.OnResize := StatusBarResize;
  FStatusBar.OnDrawPanel := StatusBarDrawPanel;
  FZoomControl := TZoomControl.Create(Self);
  FZoomControl.Parent := FStatusBar;
  FZoomControl.ZoomMin := 0;
  FZoomControl.ZoomMax := 100;
  FZoomControl.InitialZoom := 50;
  FZoomControl.Step := 1;
  FZoomControl.LinearScale := True;
  FZoomControl.LabelWidth := 50;
  FZoomControl.OnGetZoomLabel := ZoomControlGetLabel;
  FZoomControl.FactorToLevelFcn := ZoomFactorToLevel;
  FZoomControl.LevelToFactorFcn := ZoomLevelToFactor;
  FZoomControl.OnChange := ZoomControlChange;
  FAppEvents := TApplicationEvents.Create(Self);
  FAppEvents.OnHint := AppHint;
end;

function TImageViewerGUI.GetSizeGripSize: Integer;
begin
  if (Parent is TCustomForm) and (TCustomForm(Parent).WindowState = wsNormal) and
    FStatusBar.SizeGrip
  then
    Result := _scale(16)
  else
    Result := 0;
end;

procedure TImageViewerGUI.ImageZoomChange(Sender: TObject);
begin
  if Assigned(FZoomControl) and Assigned(FImageViewer) then
  begin
    FZoomControl.OnChange := nil;
    try
      FZoomControl.ZoomLevel := ZoomFactorToLevel(FImageViewer.Zoom);
    finally
      FZoomControl.OnChange := ZoomControlChange;
    end;
  end;
end;

procedure TImageViewerGUI.StatusBarDrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[STATUS_ZOOM_CONTROL] then
    FZoomControl.BoundsRect := Classes.Rect(Rect.Left, Rect.Top,
      Rect.Right - GetSizeGripSize, Rect.Bottom);
end;

procedure TImageViewerGUI.StatusBarResize(Sender: TObject);
begin
  StatusBar.Panels[STATUS_MESSAGE].Width :=
    FStatusBar.Width - FStatusBar.Panels[STATUS_SIZE].Width -
    FStatusBar.Panels[STATUS_ZOOM_CONTROL].Width;
end;

procedure TImageViewerGUI.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TImageViewerGUI.ZoomControlChange(Sender: TObject);
begin
  if Assigned(FImageViewer) and Assigned(FZoomControl) then
    FImageViewer.Zoom := ZoomLevelToFactor(FZoomControl.ZoomLevel);
end;

procedure TImageViewerGUI.ZoomControlGetLabel(ZoomControl: TZoomControl;
  const AZoomLevel: Double; var ALabel: string);
var
  f: Double;
begin
  f := ZoomLevelToFactor(AZoomLevel);
  if SameValue(f, 1) then
    ALabel := '1x'
  else if f < 1 then
    ALabel := FormatFloat('0.##', f, TFormatSettings.Invariant) + 'x'
  else if f < 10 then
    ALabel := FormatFloat('0.#', f, TFormatSettings.Invariant) + 'x'
  else
    ALabel := Round(f).ToString + 'x';
end;

function TImageViewerGUI.ZoomFactorToLevel(const AFactor: Double): Double;
begin
  if AFactor >= 1 then
    Result := 50 + (50/3) * Log10(AFactor)
  else
    Result := 50 + 25 * Log10(AFactor)
end;

function TImageViewerGUI.ZoomLevelToFactor(const ALevel: Double): Double;
begin
  if ALevel >= 50 then
    Result := Power(10, (3/50) * (ALevel - 50))
  else
    Result := Power(10, (1/25) * (ALevel - 50))
end;

procedure Register;
begin
  RegisterComponents('Rejbrand 2020', [TImageViewer, TImageViewerGUI]);
end;

end.