unit ImageViewer;
interface
uses
Windows, Messages, SysUtils, Types, Classes, UITypes, Graphics, Controls,
Forms, Menus, ComCtrls, ZoomControl, AppEvnts, IMouse;
type
TZoomMode = (zmProportionalFit, zmStretchFit, zmProportionalShrinkFit, zmFixed);
TImageViewer = class(TCustomControl)
strict private
var
LineSize: Integer;
const
MinZoom = 0.01;
MaxZoom = 1000;
CtxZoomLevelCount = 11;
CtxZoomLevels: array[0..CtxZoomLevelCount - 1] of Double = (0.25, 0.50, 0.75, 1.0, 1.25, 1.50, 2.0, 3.0, 4.0, 5.0, 10.0);
var
FBitmap: TBitmap;
FZoom: Double;
FScrollPos: TPoint;
FZoomMode: TZoomMode;
FDragPos: TPoint;
FContextMenu: TPopupMenu;
FmiProportionalShrinkFit,
FmiProportionalFit,
FmiStretchFit,
FmiFixed,
FmiZoomIn,
FmiZoomOut,
FmiZoomLevel,
FmiCopy,
FmiSaveAs,
FmiNewWindow,
FmiFullscreen,
FmiExitFullscreen,
FmiShowStatusbar,
FmiSetBackground: TMenuItem;
FmiZoomLevels: array[0..CtxZoomLevelCount - 1] of TMenuItem;
FOnZoomChange: TNotifyEvent;
FOnZoomChangeDyn: TNotifyEvent;
FOnBitmapChanged: TNotifyEvent;
FOwnsSecondaryWindows: Boolean;
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);
procedure SetZoomLevel(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 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 OwnsSecondaryWindows: Boolean read FOwnsSecondaryWindows write FOwnsSecondaryWindows;
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 OnKeyDown;
property OnKeyPress;
property OnKeyUp;
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;
begin
SetLength(Result, AFileName.Length);
var c := 0;
for var i := 1 to AFileName.Length do
if TPath.IsValidFileNameChar(AFileName[i]) then
begin
Inc(c);
Result[c] := AFileName[i];
end;
SetLength(Result, c);
end;
procedure TImageViewer.CMMouseEnter(var Message: TMessage);
begin
UpdateCursor;
inherited;
end;
procedure TImageViewer.ContextPopup(Sender: TObject);
begin
var 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;
var LZoomTag := Round(1000 * Zoom);
for var LIdx := 0 to CtxZoomLevelCount - 1 do
begin
FmiZoomLevels[LIdx].Enabled := Assigned(FBitmap);
FmiZoomLevels[LIdx].Checked := LZoomTag = FmiZoomLevels[LIdx].Tag;
end;
end;
procedure TImageViewer.CopyToClipboard(Sender: TObject);
begin
if Assigned(FBitmap) then
Clipboard.Assign(FBitmap);
end;
constructor TImageViewer.Create(AOwner: TComponent);
const
MenuGroup_ZoomMode = 1;
MenuGroup_ZoomLevel = 2;
begin
inherited;
FOwnsSecondaryWindows := False;
var FS := TFormatSettings.Invariant;
LineSize := _scale(10);
TabStop := True;
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, csPannable];
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.GroupIndex := MenuGroup_ZoomMode;
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.GroupIndex := MenuGroup_ZoomMode;
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.GroupIndex := MenuGroup_ZoomMode;
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.GroupIndex := MenuGroup_ZoomMode;
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);
FmiZoomLevel := TMenuItem.Create(FContextMenu);
FmiZoomLevel.Caption := 'Zoom factor';
FContextMenu.Items.Add(FmiZoomLevel);
FContextMenu.Items.InsertNewLineAfter(FmiZoomLevel);
for var LIdx := 0 to CtxZoomLevelCount - 1 do
begin
var LFactor := CtxZoomLevels[LIdx];
var Hotkey := '';
var LPct := Round(100 * LFactor);
if (Round(LFactor) = LFactor) and InRange(Round(LFactor), 0, 9) then
Hotkey := #9 + Round(LFactor).ToString;
FmiZoomLevels[LIdx] := TMenuItem.Create(FmiZoomLevel);
FmiZoomLevels[LIdx].Caption := LPct.ToString + '%' + Hotkey;
FmiZoomLevels[LIdx].Hint := 'Sets the zoom level to ' + LPct.ToString + '%';
FmiZoomLevels[LIdx].Tag := Round(1000 * LFactor);
FmiZoomLevels[LIdx].RadioItem := True;
FmiZoomLevels[LIdx].GroupIndex := MenuGroup_ZoomLevel;
FmiZoomLevels[LIdx].OnClick := SetZoomLevel;
FmiZoomLevel.Add(FmiZoomLevels[LIdx]);
end;
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;
var LLineSize := LineSize;
if ssCtrl in Shift then
LLineSize := 10 * LineSize
else if ssShift in Shift then
LLineSize := 1;
case Key of
VK_UP:
SetScrollPosY(FScrollPos.Y - LLineSize);
VK_DOWN:
SetScrollPosY(FScrollPos.Y + LLineSize);
VK_RIGHT:
SetScrollPosX(FScrollPos.X + LLineSize);
VK_LEFT:
SetScrollPosX(FScrollPos.X - LLineSize);
VK_NEXT:
if ssCtrl in Shift then
SetScrollPosY(ZoomedHeight - ClientHeight)
else
SetScrollPosY(FScrollPos.Y + ClientHeight);
VK_PRIOR:
if ssCtrl in Shift then
SetScrollPosY(0)
else
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;
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;
begin
if FOwnsSecondaryWindows then
Frm := TForm.Create(Self)
else
Frm := TForm.Create(Application);
Frm.Color := clWhite;
Frm.Caption := Caption;
Frm.OnClose := TImgWnd.FormClose;
Frm.Width := _scale(800);
Frm.Height := _scale(600);
var 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;
procedure TFullscreenForm.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
inherited;
if BorderStyle = bsNone then
BoundsRect := Screen.MonitorFromWindow(Handle, mdNearest).BoundsRect;
end;
procedure TImageViewer.DisplayFullscreen(Sender: TObject);
begin
var 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;
var 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, HALFTONE);
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);
begin
var 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.SetZoomLevel(Sender: TObject);
begin
if Sender is TMenuItem then
begin
var MI := TMenuItem(Sender);
Zoom := MI.Tag / 1000;
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);
ShowScrollBar(Handle, SB_VERT, SI.nMax > ClientHeight);
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);
ShowScrollBar(Handle, SB_HORZ, SI.nMax > ClientWidth);
end;
end;
procedure TImageViewer.WMContextMenu(var Message: TWMContextMenu);
var
p: TPoint;
begin
if (Message.XPos = -1) and (Message.YPos = -1) then
with ClientToScreen(ClientRect.CenterPoint) do
FContextMenu.Popup(x, y)
else
begin
p := ScreenToClient(Message.Pos);
if (p.X >= ClientWidth) or (p.Y >= ClientHeight) then
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.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
inherited;
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;
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.