Масштабирование через StretchDraw

[Montysson]

Всем привет, я уже создавал тему про масштабирование, но никто не ответил, поэтому я масштабирование переделал по другому и снова появился касяк, теперь я масштабирую следующим образом:

procedure TfrmMain.btnZoomInClick(Sender: TObject);
begin
  if ScaleCoef < 3 then
  begin
    // Увеличение коэффициента масштабирования
    ScaleCoef := ScaleCoef + 0.2;
    // Масштабирование
    ImageScaling;
    // Проверка максимального и минимального значений коэффициента
    if ScaleCoef >= 3 then
      btnZoomIn.Enabled := False;
    if ScaleCoef >= 0.2 then
      btnZoomOut.Enabled := True;
  end;
end;

procedure TfrmMain.ImageScaling;
var
  // Отмасштабированные размеры
  ScaledWidth: Integer;
  ScaledHeight: Integer;
begin
  // Задание размеров буфера и изменение картинки
  // Отмасштабированная длина
  ScaledWidth := Round(OrignWidth * ScaleCoef);
  // Отмасштабированная ширина
  ScaledHeight := Round(OrignHeight * ScaleCoef);
  // Задание размеров буфера
  imgDrawingBuffer.Width := ScaledWidth;
  imgDrawingBuffer.Height := ScaledHeight;
  // Задание размеров основного изображения
  imgOutput.Width := ScaledWidth;
  imgOutput.Height := ScaledHeight;
  // Отрисовка отмасштабированного изображения
  imgOutput.Canvas.StretchDraw(Rect(0, 0, ScaledWidth, ScaledHeight),
    imgDrawingBuffer.Picture.Graphic);
  // Центрирование изображения
  SetImagePosition(imgOutput, ScrollBox.Width, ScrollBox.Height);
end;

Когда я уменьшаю изображение, то все нормально:


А когда увеличиваю сам размер изображения увеличивается, оно масштабируется, но отрисовывается только часть, причем по размерам эта часть равна исходному размеру изображения:

[Montysson]

Похоже форум умер, хер кто откликнется, а зачем, есть же темы попроще "Как рисовать прямоугольник", "Загрузка файла", "Вывод в мемо", а как тема чуть посложнее, то сразу оо да ну нах, даже смотреть такую тему не буду

[Montysson]

Думаю меня скоро покарают модераторы за дабл- или уже триплпост, ну да ладно, надо тему поднять, потому что вопрос очень очень щас актуален.

Что здесь не так?

procedure TfrmMain.ImageScaling2;
var
  Bitmap1, Bitmap2: TBitmap;
  // Отмасштабированные размеры
  ScaledWidth: Integer;
  ScaledHeight: Integer;
begin
  Bitmap1 := TBitmap.Create;
  Bitmap2 := TBitmap.Create;
  try
    // Отмасштабированная длина
    ScaledWidth := Round(OrignWidth * ScaleCoef);
    // Отмасштабированная ширина
    ScaledHeight := Round(OrignHeight * ScaleCoef);
    Bitmap2.PixelFormat := pf24Bit;
    Bitmap1.SetSize(OrignWidth, OrignHeight);
    Bitmap1.Canvas.Draw(0, 0, imgDrawingBuffer.Picture.Graphic);
    Bitmap2.SetSize(ScaledWidth, ScaledHeight);
    Bitmap2.Canvas.StretchDraw(Rect(0, 0, Bitmap2.Width,
        Bitmap2.Height), Bitmap1);
    imgOutput.Assign(Bitmap2);
    SetImagePosition(imgOutput, ScrollBox.Width, ScrollBox.Height);
  finally
    Bitmap1.Free;
    Bitmap2.Free;
  end;
end;

Вот ошибка: First chance exception at $76A5B9BC. Exception class EConvertError with message 'Cannot assign a TBitmap to a TImage'. Process Coursework.exe (6428)

[Аватар]

imgOutput.Picture.Bitmap.Assign(Bitmap2);
Может и imgOutput.Picture.Assign(Bitmap2); прокатит

[Montysson]

Аватар, спасибо, ну точно же, ошибка то однозначная, смотрю и не вижу) :D

Только проблема не решилась, когда увеличиваю масштаб изображения сама картинка растягивается, но так же касячно, т.е. рисуется только часть

[Аватар]

Что-то не пойму проблемы. Делайте у Image Stretch и Proportional True, а Autosize False. Меняйте пропорционально исходный размер и получите то что надо.

Похоже форум умер, хер кто откликнется, а зачем, есть же темы попроще "Как рисовать прямоугольник", "Загрузка файла", "Вывод в мемо", а как тема чуть посложнее, то сразу оо да ну нах, даже смотреть такую тему не буду

Это вы зря. Никто никому и ничем на форуме не обязан

[BLACK_RAIN]

procedure setrect(var rect: trect; left,top,right,bottom : integer);
begin
  rect.Left:= left;
  rect.Top:= top;
  rect.Right:= right;
  rect.Bottom := bottom;
end;

procedure ResizeRect(var r: TRect; const r2: TRect);
var
vaspect:real;
paspect:real;
newh,neww:integer;
x,y,w,h : integer;
x2,y2,w2,h2 : Integer;
begin
  vaspect := 0;
  paspect := 0;
  x := R.Left;
  y := R.Top;
  w := R.Right-r.Left;
  h := R.Bottom-r.Top;
  if (w<=0) or (h<=0) then Exit;
  x2 := r2.Left;
  y2 := r2.Top;
  neww := r2.Right-r2.Left;
  newh := r2.Bottom-r2.Top;
if (newh<=0) or (neww<=0) then exit;
vaspect:= h / w;
paspect:= newh/neww;
if (vaspect>paspect) then
 begin
// newh:=H;
 neww:=trunc(NewH /vaspect);
 end else if(vaspect<paspect) then
   begin
//   neww:=W;
   newh:=trunc(NewW*vaspect);
   end;{ else          `
     begin
     neww:=W;
     Newh:=H;
     end;}
  SetRect(r,0,0,neww,newh);
end;

procedure CenterRect(var r: TRect; const r2: TRect);
var
  x,y,w,h, x2,y2,w2,h2 : Integer;
begin
  x2 := r2.Left;
  y2 := r2.Top;
  w2 := r2.Right-r2.Left;
  h2 := r2.Bottom-r2.Top;
  x := r.Left;
  y := r.Top;
  w := r.Right-r.Left;
  h := r.Bottom-r.Top;
  x := (w2 div 2)-(w div 2);
  y := (h2 div 2)-(h div 2);
  SetRect(r,x,y,w+x,h+y);
end;