atimagebox.pas

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

  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
      SetStretchBltMode(Handle, STRETCH_HALFTONE);
      SetBrushOrgEx(Handle, 0, 0, nil);
      StretchBlt(
        Handle,
        DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
        Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height,
        SRCCOPY);
    end;
  finally
    Bmp.Free;
  end;

  if Assigned(FOnPaint) then
    FOnPaint(Self);
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;
  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
  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.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;
    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;
    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