atimagebox.pas

ATViewer is a component for Delphi/C++Builder, which allows to view files of various types. There is

{************************************************}
{                                                }
{  ATImageBox Component                          }
{  Copyright (C) 2007 Alexey Torgashin           }
{  http://atorg.net.ru                           }
{  [e-mail]                        }
{                                                }
{************************************************}

{$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 .. 30] of Integer = (
    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};

type
  TATImage = class(TGraphicControl)
  private
    FPicture: TPictureWide;
    FOnPaint: TNotifyEvent;
    FOnProgress: TProgressEvent;
    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;
  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;
  end;

type
  TATImageBox = class(TScrollBox)
  private
    FFocusable: Boolean;
    FImage: TATImage;
    FImageLabel: TLabel;
    FImageWidth: Integer;
    FImageHeight: Integer;
    FImageFit: Boolean;
    FImageFitOnlyBig: Boolean;
    FImageCenter: Boolean;
    FImageScale: Integer;
    FImageKeepPosition: Boolean;
    FImageDrag: Boolean;
    FImageDragCursor: TCursor;
    FImageScaleCursor: TCursor;
    FImageDragging: Boolean;
    FImageDraggingPoint: TPoint;
    FImageMouseDown: Boolean;
    FOnScroll: TNotifyEvent;
    FOnOptionsChange: TNotifyEvent;
    procedure DoScroll;
    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 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);

  public
    constructor Create(AOwner: TComponent); override;
    procedure UpdateImageInfo;
    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 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 OnOptionsChange: TNotifyEvent read FOnOptionsChange write FOnOptionsChange;
  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;
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;
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
    //Do the standard rendering
    with inherited Canvas do
      StretchDraw(DestRect, Picture.Graphic);

    //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.PaintResampled;
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;