Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1347 lines (1204 sloc) 33.1 KB
{************************************}
{ }
{ ATImageBox Component }
{ Copyright (C) Alexey Torgashin }
{ http://www.uvviewsoft.com }
{ }
{************************************}
{$BOOLEVAL OFF} //Short boolean evaluation required
{$I ATImageBoxOptions.inc} //ATImageBox options
unit ATImageBox;
interface
uses
Windows, Messages, Classes, Controls, Graphics,
StdCtrls, ExtCtrls,
{$ifdef TNT} TntGraphics, {$endif}
Forms;
const
cViewerDefaultResampleDelay = 300;
cViewerImageScales: array[1 .. 33] of Integer = (
1, 2, 4, 7, 10, 15, 20, 25, 30,
40, 50, 60, 70, 80, 90, 100,
125, 150, 175, 200, 250, 300, 350, 400, 450, 500,
600, 700, 800, 1000, 1200, 1400, 1600);
type
TPictureWide = {$ifdef TNT}TTntPicture{$else}TPicture{$endif};
TATScrollAltEvent = procedure(Sender: TObject; Inc: Boolean) of object;
TATOnAfterPaint = procedure(Sender: TObject; aCanvas: TCanvas; const aDrawRec: TRect) of object;
type
TATImage = class(TGraphicControl)
private
FPicture: TPictureWide;
FOnPaint: TNotifyEvent;
FOnProgress: TProgressEvent;
FOnAfterPaint: TATOnAfterPaint;
FStretch: Boolean;
FCenter: Boolean;
FIncrementalDisplay: Boolean;
FTransparent: Boolean;
FResample: Boolean;
FResampleBackColor: TColor;
FDrawing: Boolean;
FProportional: Boolean;
FTimer: TTimer; //Helper timer to do resampling after a delay
procedure PictureChanged(Sender: TObject);
procedure SetCenter(Value: Boolean);
procedure SetPicture(Value: TPictureWide);
procedure SetStretch(Value: Boolean);
procedure SetTransparent(Value: Boolean);
procedure SetProportional(Value: Boolean);
procedure SetResample(Value: Boolean);
procedure TimerTimer(Sender: TObject);
procedure PaintResampled;
function GetResampleDelay: Integer;
procedure SetResampleDelay(AValue: Integer);
protected
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
function DestRect: TRect;
function DoPaletteChange: Boolean;
function GetPalette: HPALETTE; override;
procedure Paint; override;
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
procedure DoExtraPaint(const aRect: TRect);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Align;
property Anchors;
property AutoSize;
property Center: Boolean read FCenter write SetCenter default False;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False;
property ParentShowHint;
property Picture: TPictureWide read FPicture write SetPicture;
property PopupMenu;
property Proportional: Boolean read FProportional write SetProportional default false;
property ShowHint;
property Stretch: Boolean read FStretch write SetStretch default False;
property Transparent: Boolean read FTransparent write SetTransparent default False;
property Resample: Boolean read FResample write SetResample default False;
property ResampleDelay: Integer read GetResampleDelay write SetResampleDelay default cViewerDefaultResampleDelay;
property ResampleBackColor: TColor read FResampleBackColor write FResampleBackColor default clWhite;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
property OnStartDock;
property OnStartDrag;
property OnAfterPaint: TATOnAfterPaint read FOnAfterPaint write FOnAfterPaint;
end;
type
TATImageBox = class(TScrollBox)
private
FFocusable: Boolean;
FIsGif: Boolean;
FImageGif: TImage;
FImage: TATImage;
FImageLabel: TLabel;
FImageWidth: Integer;
FImageHeight: Integer;
FImageFit,
FImageFitOnlyBig,
FImageFitWidth,
FImageFitHeight,
FImageCenter: Boolean;
FImageScale: Integer;
FImageKeepPosition: Boolean;
FImageDrag: Boolean;
FImageDragCursor: TCursor;
FImageScaleCursor: TCursor;
FImageDragging: Boolean;
FImageDraggingPoint: TPoint;
FImageMouseDown: Boolean;
FOnScroll: TNotifyEvent;
FOnScrollAlt: TATScrollAltEvent;
FOnOptionsChange: TNotifyEvent;
procedure DoScroll;
procedure DoScrollAlt(AInc: Boolean);
procedure DoOptionsChange;
procedure MouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure MouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure UpdateImagePosition(AResetPosition: Boolean = False);
procedure UpdateImageLabelPosition;
procedure SetImageFit(AValue: Boolean);
procedure SetImageFitOnlyBig(AValue: Boolean);
procedure SetImageFitWidth(AValue: Boolean);
procedure SetImageFitHeight(AValue: Boolean);
procedure SetImageCenter(AValue: Boolean);
procedure SetImageScale(AValue: Integer);
procedure ImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure ImagePaint(Sender: TObject);
procedure ImageProgress(Sender: TObject;
Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
function GetOnAfterPaint: TATOnAfterPaint;
procedure SetOnAfterPaint(Value: TATOnAfterPaint);
public
constructor Create(AOwner: TComponent); override;
procedure LoadFromFile(const FN: string);
procedure LoadBitmap(ABitmap: TBitmap; ATransp: Boolean);
procedure LoadPicture(APicture: TPicture);
procedure Unload;
procedure UpdateInfo;
function CurrentPicture: TPicture;
procedure IncreaseImageScale(AIncrement: Boolean);
property Image: TATImage read FImage;
property ImageLabel: TLabel read FImageLabel;
property ImageWidth: Integer read FImageWidth;
property ImageHeight: Integer read FImageHeight;
property ImageScale: Integer read FImageScale write SetImageScale;
protected
procedure WMHScroll(var Msg: TMessage); message WM_HSCROLL;
procedure WMVScroll(var Msg: TMessage); message WM_VSCROLL;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Resize; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
published
property Focusable: Boolean read FFocusable write FFocusable default True;
property ImageFitToWindow: Boolean read FImageFit write SetImageFit default False;
property ImageFitOnlyBig: Boolean read FImageFitOnlyBig write SetImageFitOnlyBig default True;
property ImageFitWidth: Boolean read FImageFitWidth write SetImageFitWidth default False;
property ImageFitHeight: Boolean read FImageFitHeight write SetImageFitHeight default False;
property ImageCenter: Boolean read FImageCenter write SetImageCenter default True;
property ImageKeepPosition: Boolean read FImageKeepPosition write FImageKeepPosition default True;
property ImageDrag: Boolean read FImageDrag write FImageDrag default True;
property ImageDragCursor: TCursor read FImageDragCursor write FImageDragCursor default crSizeAll;
property ImageScaleCursor: TCursor read FImageScaleCursor write FImageScaleCursor default crSizeNS;
property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
property OnScrollAlt: TATScrollAltEvent read FOnScrollAlt write FOnScrollAlt;
property OnOptionsChange: TNotifyEvent read FOnOptionsChange write FOnOptionsChange;
property OnAfterPaint: TATOnAfterPaint read GetOnAfterPaint write SetOnAfterPaint;
end;
procedure Register;
implementation
uses
SysUtils
{$ifdef GIF} , GifImage {$endif};
{ Constants }
const
cImageLineSize = 50; //Line size: pixels to scroll by arrows and mouse sheel
cImageGapSize = 20; //Gap size: PgUp/PgDn/Home/End scroll by control size minus gap size
{ Helper functions }
function IMax(N1, N2: Integer): Integer;
begin
if N1 >= N2 then
Result := N1
else
Result := N2;
end;
function IMin(N1, N2: Integer): Integer;
begin
if N1 <= N2 then
Result := N1
else
Result := N2;
end;
{
We need to "fix" icon sizes. Icon should be drawn once before its sizes are to be read.
http://qc.codegear.com/wc/qcmain.aspx?d=6018
}
procedure FixIcon(AIcon: TIcon);
var
Bmp: TBitmap;
begin
try
Bmp:= TBitmap.Create;
try
Bmp.PixelFormat := pf24bit;
Bmp.Canvas.Draw(0, 0, AIcon);
finally
Bmp.Free;
end;
except
end;
end;
{
Scaling doesn't work with icons. So, we need to convert icon to a bitmap,
preferrably with PixelFormat = pf24bit.
}
function FixImageFormat(AImage: TATImage; ABackColor: TColor): Boolean;
var
bmp: TBitmap;
begin
Result := True;
with AImage.Picture do
if (not (Graphic is TBitmap)) or ((TBitmap(Graphic).PixelFormat <> pf24Bit)) then
try
bmp := TBitmap.Create;
try
bmp.PixelFormat := pf24bit;
bmp.Width := Graphic.Width;
bmp.Height := Graphic.Height;
bmp.Canvas.Brush.Color:= ABackColor;
bmp.Canvas.FillRect(Rect(0, 0, bmp.Width, bmp.Height));
bmp.Canvas.Draw(0, 0, Graphic);
AImage.Picture.Graphic := bmp;
finally
bmp.Free;
end;
except
Result := False;
end;
end;
{ TATImage }
constructor TATImage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
FPicture := TPictureWide.Create;
FPicture.OnChange := PictureChanged;
FPicture.OnProgress := Progress;
Height := 105;
Width := 105;
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.Interval := cViewerDefaultResampleDelay;
FTimer.OnTimer := TimerTimer;
FResampleBackColor := clWhite;
FOnAfterPaint := nil;
end;
destructor TATImage.Destroy;
begin
FPicture.Free;
inherited Destroy;
end;
function TATImage.GetPalette: HPALETTE;
begin
Result := 0;
if FPicture.Graphic <> nil then
Result := FPicture.Graphic.Palette;
end;
function TATImage.DestRect: TRect;
var
w, h, cw, ch: Integer;
xyaspect: Double;
begin
w := Picture.Width;
h := Picture.Height;
cw := ClientWidth;
ch := ClientHeight;
if Stretch or (Proportional and ((w > cw) or (h > ch))) then
begin
if Proportional and (w > 0) and (h > 0) then
begin
xyaspect := w / h;
if w > h then
begin
w := cw;
h := Trunc(cw / xyaspect);
if h > ch then // woops, too big
begin
h := ch;
w := Trunc(ch * xyaspect);
end;
end
else
begin
h := ch;
w := Trunc(ch * xyaspect);
if w > cw then // woops, too big
begin
w := cw;
h := Trunc(cw / xyaspect);
end;
end;
end
else
begin
w := cw;
h := ch;
end;
end;
with Result do
begin
Left := 0;
Top := 0;
Right := w;
Bottom := h;
end;
if Center then
OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);
end;
procedure TATImage.Paint;
var
Save: Boolean;
tmpRect: TRect;
begin
if csDesigning in ComponentState then
with inherited Canvas do
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle(0, 0, Width, Height);
end;
Save := FDrawing;
FDrawing := True;
try
tmpRect := DestRect;
//Do the standard rendering
with inherited Canvas do
StretchDraw(tmpRect, Picture.Graphic);
DoExtraPaint(tmpRect);
//Do the delayed resampling rendering
if FResample
//Do not resample metafiles:
and not (Picture.Graphic is TMetafile)
(*ifdef GIF}
//Do not resample *animated* GIF images:
and not ((Picture.Graphic is TGifImage) and ((Picture.Graphic as TGifImage).Images.Count > 1))
endif}*) then
begin
FTimer.Enabled := False;
FTimer.Enabled := True;
end;
finally
FDrawing := Save;
end;
end;
procedure TATImage.DoExtraPaint(const aRect: TRect);
begin
if Assigned(FOnAfterPaint) then
FOnAfterPaint(Self, inherited Canvas, aRect);
end;
procedure TATImage.PaintResampled;
var
Bmp: TBitmap;
tmpRect: TRect;
begin
Bmp := TBitmap.Create;
try
with Bmp do
begin
PixelFormat := pf24bit;
Width := Picture.Width;
Height := Picture.Height;
Canvas.Brush.Color := FResampleBackColor;
Canvas.FillRect(Rect(0, 0, Width, Height));
Canvas.Draw(0, 0, Picture.Graphic);
end;
with inherited Canvas do
begin
tmpRect := DestRect;
SetStretchBltMode(Handle, STRETCH_HALFTONE);
SetBrushOrgEx(Handle, 0, 0, nil);
StretchBlt(
Handle,
tmpRect.Left, tmpRect.Top, tmpRect.Right - tmpRect.Left, tmpRect.Bottom - tmpRect.Top,
Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
SRCCOPY);
end;
finally
Bmp.Free;
end;
if Assigned(FOnPaint) then
FOnPaint(Self);
DoExtraPaint(tmpRect);
end;
function TATImage.DoPaletteChange: Boolean;
var
ParentForm: TCustomForm;
Tmp: TGraphic;
begin
Result := False;
Tmp := Picture.Graphic;
if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and
(Tmp.PaletteModified) then
begin
if (Tmp.Palette = 0) then
Tmp.PaletteModified := False
else
begin
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then
begin
if FDrawing then
ParentForm.Perform(wm_QueryNewPalette, 0, 0)
else
PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
Result := True;
Tmp.PaletteModified := False;
end;
end;
end;
end;
procedure TATImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if FIncrementalDisplay and RedrawNow then
begin
if DoPaletteChange then Update
else Paint;
end;
if Assigned(FOnProgress) then FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
procedure TATImage.SetCenter(Value: Boolean);
begin
if FCenter <> Value then
begin
FCenter := Value;
PictureChanged(Self);
end;
end;
procedure TATImage.SetPicture(Value: TPictureWide);
begin
FPicture.Assign(Value);
end;
procedure TATImage.SetStretch(Value: Boolean);
begin
if Value <> FStretch then
begin
FStretch := Value;
PictureChanged(Self);
end;
end;
procedure TATImage.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then
begin
FTransparent := Value;
PictureChanged(Self);
end;
end;
procedure TATImage.SetProportional(Value: Boolean);
begin
if FProportional <> Value then
begin
FProportional := Value;
PictureChanged(Self);
end;
end;
procedure TATImage.SetResample(Value: Boolean);
begin
//Resampling works only under WinNT, since
//STRETCH_HALFTONE doesn't work under Win9x
if Win32Platform = VER_PLATFORM_WIN32_NT then
if Value <> FResample then
begin
FResample := Value;
PictureChanged(Self);
end;
end;
procedure TATImage.PictureChanged(Sender: TObject);
var
G: TGraphic;
D : TRect;
begin
if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
SetBounds(Left, Top, Picture.Width, Picture.Height);
G := Picture.Graphic;
if G <> nil then
begin
if not ((G is TMetaFile) or (G is TIcon)) then
G.Transparent := FTransparent;
D := DestRect;
if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and
(D.Right >= Width) and (D.Bottom >= Height) then
ControlStyle := ControlStyle + [csOpaque]
else // picture might not cover entire clientrect
ControlStyle := ControlStyle - [csOpaque];
if DoPaletteChange and FDrawing then Update;
end
else ControlStyle := ControlStyle - [csOpaque];
if not FDrawing then Invalidate;
end;
function TATImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
Result := True;
if not (csDesigning in ComponentState) or (Picture.Width > 0) and
(Picture.Height > 0) then
begin
if Align in [alNone, alLeft, alRight] then
NewWidth := Picture.Width;
if Align in [alNone, alTop, alBottom] then
NewHeight := Picture.Height;
end;
end;
procedure TATImage.TimerTimer(Sender: TObject);
begin
FTimer.Enabled := False;
PaintResampled;
end;
function TATImage.GetResampleDelay: Integer;
begin
Result := FTimer.Interval;
end;
procedure TATImage.SetResampleDelay(AValue: Integer);
begin
FTimer.Interval := AValue;
end;
{ TATImageBox }
constructor TATImageBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//Init inherited properties
AutoScroll := False;
DoubleBuffered := True; //To remove flicker when new image is loaded
HorzScrollBar.Tracking := True;
VertScrollBar.Tracking := True;
//Init fields
FFocusable:= True;
FImageFit := False;
FImageFitOnlyBig := True;
FImageFitWidth := False;
FImageFitHeight := False;
FImageCenter := True;
FImageWidth := 0;
FImageHeight := 0;
FImageScale := 100;
FImageKeepPosition := True;
FImageDrag := True;
FImageDragCursor := crSizeAll;
FImageScaleCursor := crSizeNS;
FImageDragging := False;
FImageDraggingPoint := Point(0, 0);
FImageMouseDown := False;
//Init objects
FImageGif := TImage.Create(Self);
with FImageGif do
begin
Parent := Self;
Align := alClient;
AutoSize := False;
Center := True;
Proportional := True;
end;
FImage := TATImage.Create(Self);
with FImage do
begin
Parent := Self;
Align := alNone;
AutoSize := False;
IncrementalDisplay := True;
OnMouseDown := ImageMouseDown;
OnMouseUp := ImageMouseUp;
OnMouseMove := ImageMouseMove;
OnPaint := ImagePaint;
OnProgress := ImageProgress;
end;
FImageLabel := TLabel.Create(Self);
with FImageLabel do
begin
Parent := Self;
Visible := False;
Brush.Style := bsClear;
Font.Style := [fsBold];
Font.Color := clWhite;
Caption := '';
end;
//Init event handlers
OnMouseWheelUp := MouseWheelUp;
OnMouseWheelDown := MouseWheelDown;
end;
procedure TATImageBox.DoScroll;
begin
UpdateImageLabelPosition;
if Assigned(FOnScroll) then
FOnScroll(Self);
end;
procedure TATImageBox.DoScrollAlt(AInc: Boolean);
begin
if Assigned(FOnScrollAlt) then
FOnScrollAlt(Self, AInc);
end;
procedure TATImageBox.WMHScroll(var Msg: TMessage);
begin
inherited;
DoScroll;
end;
procedure TATImageBox.WMVScroll(var Msg: TMessage);
begin
inherited;
DoScroll;
end;
procedure TATImageBox.MouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
if (Shift = []) then
begin
with VertScrollBar do
Position := Position - cImageLineSize;
DoScroll;
end
else
if (Shift = [ssShift]) then
begin
with HorzScrollBar do
Position := Position - cImageLineSize;
DoScroll;
end
else
if (Shift = [ssCtrl]) or FImageMouseDown then
begin
IncreaseImageScale(True);
FImageDragging := False;
if FImageMouseDown then
Screen.Cursor := FImageScaleCursor;
end;
Handled := True;
end;
procedure TATImageBox.MouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
if (Shift = []) then
begin
with VertScrollBar do
Position := Position + cImageLineSize;
DoScroll;
end
else
if (Shift = [ssShift]) then
begin
with HorzScrollBar do
Position := Position + cImageLineSize;
DoScroll;
end
else
if (Shift = [ssCtrl]) or FImageMouseDown then
begin
IncreaseImageScale(False);
FImageDragging := False;
if FImageMouseDown then
Screen.Cursor := FImageScaleCursor;
end;
Handled := True;
end;
procedure TATImageBox.WMGetDlgCode(var Message: TMessage);
begin
Message.Result := DLGC_WANTARROWS;
end;
procedure TATImageBox.KeyDown(var Key: Word; Shift: TShiftState);
function PageSize(AClientSize: Integer): Integer;
begin
Result := IMax(AClientSize - cImageGapSize, AClientSize div 3 * 2);
end;
begin
case Key of
VK_LEFT:
begin
if Shift = [] then
begin
with HorzScrollBar do
Position := Position - cImageLineSize;
DoScroll;
Key := 0;
end
else
if Shift = [ssCtrl] then
begin
with HorzScrollBar do
Position := 0;
DoScroll;
Key := 0;
end
else
if Shift = [ssAlt] then
begin
DoScrollAlt(False);
Key := 0;
end;
end;
VK_RIGHT:
begin
if Shift = [] then
begin
with HorzScrollBar do
Position := Position + cImageLineSize;
DoScroll;
Key := 0;
end
else
if Shift = [ssCtrl] then
begin
with HorzScrollBar do
Position := Range;
DoScroll;
Key := 0;
end
else
if Shift = [ssAlt] then
begin
DoScrollAlt(True);
Key := 0;
end;
end;
VK_HOME:
if Shift = [] then
begin
with HorzScrollBar do
Position := Position - PageSize(ClientWidth);
DoScroll;
Key := 0;
end;
VK_END:
if Shift = [] then
begin
with HorzScrollBar do
Position := Position + PageSize(ClientWidth);
DoScroll;
Key := 0;
end;
VK_UP:
begin
if Shift = [] then
begin
with VertScrollBar do
Position := Position - cImageLineSize;
DoScroll;
Key := 0;
end
else
if Shift = [ssCtrl] then
begin
with VertScrollBar do
Position := 0;
DoScroll;
Key := 0;
end;
end;
VK_DOWN:
begin
if Shift = [] then
begin
with VertScrollBar do
Position := Position + cImageLineSize;
DoScroll;
Key := 0;
end
else
if Shift = [ssCtrl] then
begin
with VertScrollBar do
Position := Range;
DoScroll;
Key := 0;
end;
end;
VK_PRIOR:
if Shift = [] then
begin
with VertScrollBar do
Position := Position - PageSize(ClientHeight);
DoScroll;
Key := 0;
end;
VK_NEXT:
if Shift = [] then
begin
with VertScrollBar do
Position := Position + PageSize(ClientHeight);
DoScroll;
Key := 0;
end;
end;
end;
procedure TATImageBox.UpdateImagePosition(AResetPosition: Boolean = False);
var
AKeepPosition: Boolean;
AWidth, AHeight,
ANewWidth, ANewHeight,
ANewLeft, ANewTop,
AScrollMaxX, AScrollMaxY: Integer;
ARatio, AImageRatio,
ACenterRatioX, ACenterRatioY: Double;
begin
AKeepPosition := FImageKeepPosition and (not AResetPosition);
AWidth := ClientWidth;
AHeight := ClientHeight;
//Save center position, need to restore it later
ACenterRatioX := 0;
ACenterRatioY := 0;
if FImage.Width > 0 then
begin
if FImage.Left >= 0 then
ACenterRatioX := (AWidth div 2 - FImage.Left) / FImage.Width
else
ACenterRatioX := (AWidth div 2 + HorzScrollBar.Position) / FImage.Width;
end;
if FImage.Height > 0 then
begin
if FImage.Top >= 0 then
ACenterRatioY := (AHeight div 2 - FImage.Top) / FImage.Height
else
ACenterRatioY := (AHeight div 2 + VertScrollBar.Position) / FImage.Height;
end;
//Set controls params
if not AKeepPosition then
begin
HorzScrollBar.Position := 0;
VertScrollBar.Position := 0;
end;
AutoScroll := not FImageFit;
FImage.AutoSize := (not FImageFit) and (FImageScale = 100);
FImage.Stretch := not FImage.AutoSize;
{
//Note: commented, because we convert icon to bitmap in UpdateInfo.
//Work around VCL draw bug for icons:
if FImageIsIcon then
begin
FImage.AutoSize := False;
FImage.Stretch := True;
FImage.Width := FImageWidth;
FImage.Height := FImageHeight;
end;
}
//Fit and recalculate ImageScale
FImage.Left := 0;
FImage.Top := 0;
AWidth := ClientWidth;
AHeight := ClientHeight;
if FImageFit then
begin
{
//Note: code commented in as it causes wrong scaling sometimes.
//If image is already fit, don't scale it:
if (FImage.Width = AWidth) and
(FImage.Height = AHeight) then
begin
ANewWidth := FImage.Width;
ANewHeight := FImage.Height;
end
else
}
//Need to scale
begin
ANewWidth := FImageWidth;
ANewHeight := FImageHeight;
if FImageFitOnlyBig and
(FImageWidth <= AWidth) and (FImageHeight <= AHeight) then
begin
FImageScale := 100;
end
else
begin
if (AWidth > 0) and (AHeight > 0) and
(FImageWidth > 0) and (FImageHeight > 0) then
begin
ARatio := AWidth / AHeight;
AImageRatio := FImageWidth / FImageHeight;
if ((ARatio >= AImageRatio) and (not FImageFitWidth)) or FImageFitHeight then
begin
//fit height
if FImageFitOnlyBig and (AHeight >= FImageHeight) then begin end
else
begin
ANewHeight := AHeight;
ANewWidth := Trunc(ANewHeight * AImageRatio);
FImageScale := AHeight * 100 div FImageHeight;
end;
end
else
begin
//fit width
if FImageFitOnlyBig and (AWidth >= FImageWidth) then begin end
else
begin
ANewWidth := AWidth;
ANewHeight := Trunc(ANewWidth / AImageRatio);
FImageScale := AWidth * 100 div FImageWidth;
end;
end;
end;
end
end
end //if FImageFit
else
begin
ANewWidth := Round(FImageWidth * FImageScale / 100);
ANewHeight := Round(FImageHeight * FImageScale / 100);
end;
//Update image position
ANewLeft := 0;
ANewTop := 0;
if FImageCenter then
begin
if AWidth > ANewWidth then
ANewLeft := (AWidth - ANewWidth) div 2;
if AHeight > ANewHeight then
ANewTop := (AHeight - ANewHeight) div 2;
end;
FImage.SetBounds(
ANewLeft - HorzScrollBar.Position,
ANewTop - VertScrollBar.Position,
ANewWidth,
ANewHeight);
//Restore saved center position
if AKeepPosition then
begin
if ANewLeft = 0 then
begin
AScrollMaxX := IMax(ANewWidth - AWidth, 0);
HorzScrollBar.Position :=
IMin(AScrollMaxX, Trunc(ACenterRatioX * ANewWidth) - AWidth div 2);
end
else
HorzScrollBar.Position := 0;
if ANewTop = 0 then
begin
AScrollMaxY := IMax(ANewHeight - AHeight, 0);
VertScrollBar.Position :=
IMin(AScrollMaxY, Trunc(ACenterRatioY * ANewHeight) - AHeight div 2);
end
else
VertScrollBar.Position := 0;
end;
//adjust range
HorzScrollbar.Range := ANewWidth;
VertScrollbar.Range := ANewHeight;
DoScroll;
end;
procedure TATImageBox.UpdateImageLabelPosition;
begin
FImageLabel.Left := 0;
FImageLabel.Top := 0;
end;
procedure TATImageBox.SetImageFit(AValue: Boolean);
begin
if AValue <> FImageFit then
begin
FImageFit := AValue;
if not FImageFit then
FImageScale := 100;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.SetImageFitOnlyBig(AValue: Boolean);
begin
if AValue <> FImageFitOnlyBig then
begin
FImageFitOnlyBig := AValue;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.SetImageCenter(AValue: Boolean);
begin
if AValue <> FImageCenter then
begin
FImageCenter := AValue;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.UpdateInfo;
begin
FImageWidth := 0;
FImageHeight := 0;
FImageScale := 100;
FImage.Visible := not FIsGif;
FImageGif.Visible := FIsGif;
if FIsGif and Assigned(FImageGif.Picture) and Assigned(FImageGif.Picture.Graphic) then
begin
FImageWidth := FImageGif.Picture.Width;
FImageHeight := FImageGif.Picture.Height;
end
else
if Assigned(FImage.Picture) and Assigned(FImage.Picture.Graphic) then
begin
if FImage.Picture.Graphic is TIcon then
begin
FImage.Transparent := False; //Icons are converted to bitmap in FixImageFormat,
//so we must clear the Transparent property,
//otherwise bitmap will look incorrectly a little
FixIcon(FImage.Picture.Graphic as TIcon);
FixImageFormat(FImage, Color);
end;
FImageWidth := FImage.Picture.Width;
FImageHeight := FImage.Picture.Height;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.Resize;
begin
inherited;
UpdateImagePosition;
end;
procedure TATImageBox.SetImageScale(AValue: Integer);
begin
Assert(
(AValue >= 0) and (AValue < MaxShort),
'Invalid scale value');
if FImageScale <> AValue then
begin
FImageScale := AValue;
FImageFit := False;
UpdateImagePosition;
DoOptionsChange;
end;
end;
procedure TATImageBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if FFocusable then
SetFocus;
end;
procedure TATImageBox.ImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if FFocusable then
SetFocus;
if (Button = mbLeft) then
begin
FImageMouseDown := True;
if FImageDrag then
begin
FImageDragging := True;
FImageDraggingPoint := Point(X, Y);
Screen.Cursor := FImageDragCursor;
end;
end;
end;
procedure TATImageBox.ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if (Button = mbLeft) then
begin
FImageMouseDown := False;
FImageDragging := False;
Screen.Cursor := crDefault;
end;
end;
procedure TATImageBox.ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FImageDrag and FImageDragging then
begin
HorzScrollBar.Position := HorzScrollBar.Position + (FImageDraggingPoint.X - X);
VertScrollBar.Position := VertScrollBar.Position + (FImageDraggingPoint.Y - Y);
DoScroll;
end;
end;
procedure TATImageBox.IncreaseImageScale(AIncrement: Boolean);
var
i: Integer;
begin
if FIsGif then Exit;
if AIncrement then
begin
for i := Low(cViewerImageScales) to High(cViewerImageScales) do
if cViewerImageScales[i] > ImageScale then
begin
ImageScale := cViewerImageScales[i];
Break
end;
end
else
begin
for i := High(cViewerImageScales) downto Low(cViewerImageScales) do
if cViewerImageScales[i] < ImageScale then
begin
ImageScale := cViewerImageScales[i];
Break
end;
end;
end;
procedure TATImageBox.DoOptionsChange;
begin
if Assigned(FOnOptionsChange) then
FOnOptionsChange(Self);
end;
procedure TATImageBox.ImageProgress(Sender: TObject;
Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if FImage.IncrementalDisplay then
begin
Update;
Invalidate;
end;
end;
function TATImageBox.GetOnAfterPaint: TATOnAfterPaint;
begin
Result := FImage.OnAfterPaint;
end;
procedure TATImageBox.SetOnAfterPaint(Value: TATOnAfterPaint);
begin
FImage.OnAfterPaint := Value;
end;
type
TLabelCracker = class(TLabel);
procedure TATImageBox.ImagePaint(Sender: TObject);
begin
//Debug:
//MessageBeep(MB_OK);
//Need to repaint the label since it's overdrawn by resampled image:
if FImageLabel.Visible then
TLabelCracker(FImageLabel).Paint;
end;
{ Registration }
procedure Register;
begin
RegisterComponents('Samples', [TATImageBox]);
end;
procedure TATImageBox.SetImageFitWidth(AValue: Boolean);
begin
if AValue <> FImageFitWidth then
begin
FImageFitWidth := AValue;
if AValue then
FImageFitHeight := False;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.SetImageFitHeight(AValue: Boolean);
begin
if AValue <> FImageFitHeight then
begin
FImageFitHeight := AValue;
if AValue then
FImageFitWidth := False;
UpdateImagePosition(True);
end;
end;
procedure TATImageBox.Unload;
begin
FImage.Picture := nil;
FImageGif.Picture := nil;
FIsGif := False;
UpdateInfo;
end;
procedure TATImageBox.LoadBitmap(ABitmap: TBitmap; ATransp: Boolean);
begin
Unload;
FIsGif := False;
FImage.Picture.Assign(ABitmap);
FImage.Transparent := ATransp;
UpdateInfo;
end;
procedure TATImageBox.LoadPicture(APicture: TPicture);
begin
Unload;
FIsGif := False;
FImage.Picture.Assign(APicture);
UpdateInfo;
end;
procedure TATImageBox.LoadFromFile(const FN: string);
begin
Unload;
FIsGif := UpperCase(ExtractFileExt(FN)) = '.GIF';
if FIsGif then
FImageGif.Picture.LoadFromFile(FN)
else
FImage.Picture.LoadFromFile(FN);
UpdateInfo;
end;
function TATImageBox.CurrentPicture: TPicture;
begin
if FIsGif then
Result := FImageGif.Picture
else
Result := FImage.Picture;
end;
end.
You can’t perform that action at this time.