atimagebox.pas

支持版本:Delphi 5-2009, C++Builder 5-2009 ATViewer特性： Text, Binary, Hex, Unicode：所有文件

          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 UpdateImageInfo.
  //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 then
          begin
            ANewHeight := AHeight;
            ANewWidth := Trunc(ANewHeight * AImageRatio);
            FImageScale := AHeight * 100 div FImageHeight;
          end
          else
          begin
            ANewWidth := AWidth;
            ANewHeight := Trunc(ANewWidth / AImageRatio);
            FImageScale := AWidth * 100 div FImageWidth;
          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;

  UpdateImageLabelPosition;
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.UpdateImageInfo;
begin
  FImageWidth := 0;
  FImageHeight := 0;
  FImageScale := 100;

  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);
    UpdateImageLabelPosition;
  end;
end;

procedure TATImageBox.IncreaseImageScale(AIncrement: Boolean);
var
  i: Integer;
begin
  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
  Update;
  Invalidate;
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;

end.