Жесткое масштабирование картинки при адаптивной настройке.

[Alex2013]

Короче есть простенькая задача показать картинку в дополнительном окне с "приятным для глаз масштабированием ".
Простенькая ? Щаз ! Аж два раза .

Короче, написал я вот такую кяозябру ... ( После энного числа итераций )
Где картинку мучат аж в "четыре прохода" .

Код: Выделить всё


//image3 обычная картинка типа TImage на форме
// Конопка увеличить.
procedure TForm1.Button1Click(Sender: TObject);
Const FV:Tform=Nil;
      Im:TImage=Nil;
begin
//Создаю форму и картинку
If FV=nil Then begin
FV:=Tform.Create(Self);
Fv.Top := 0;Fv.Left:=0;
Im:= TImage.Create(FV);
Im.Align:=alClient;
Im.Center := True;
Im.Stretch:=True;
Im.Proportional:=True;
FV.InsertControl(Im);
FV.Color:=LeftPanel.Color;
Fv.OnKeyDown:=@FV_FormKeyDown;// для закрытия по ESC
End;

Im.Picture.Bitmap.SetSize(1,1);
// просто Im.Picture.Clear;  делает что-то не хорошее при повторном вызове .

// Гружу картинку
If Image3.Picture.Bitmap<>Nil then begin
Im.Picture.Bitmap.Assign(Image1.Picture.Bitmap);

// Стадия "0" Грубый масштаб формы под экран  и картинку
FV.Width:=Min(image3.Picture.Bitmap.Width, Screen.Width);
FV.Height:=Min(image3.Picture.Bitmap.Height, Screen.Height-100);// (-100 менюшка винды +запас )

//Стадия  '1' Отключаю привязку к форме  и подстраиваю видимый размер  картинки
Im.Align:=alNone;
im.Width:=FV.ClientRect.Width;
im.Height:=FV.ClientRect.Height;

// Стадия  "2"  снова подстраиваю размер окна 
( "Неестественный чат" на голубом глазу советовал Im.Picture.Width и Height - не работает !)
FV.Width:=Im.DestRect.Width;
FV.Height:=Im.DestRect.Height;
// что это за DestRect понятия не имею  но с ним окно на конец "скомпактифицировалось"  как надо

//Стадия '3' Окончательная доводка ! Снова выключаю привязку к форме.
Im.Align:=alClient;
FV.Show;
End;
end;


Блин! Ну неужели нельзя сделать тоже самое проще

[Sharfik]

Я делал так. Задача взять картинку и уменьшить до максимально допустимого размера. Вот думаю если вместо канвы взять какой ни будь BGRACanva, то наверно красиво будет.

Код: Выделить всё

procedure TFGetImageFile.btnApplyClick(Sender: TObject);
const
  OUTSIZE_H = 512;
  OUTSIZE_W = 512;
var
  TempFile,
  TempImgFile,
  TmpInFilename,
  s1          :String;
  TmpBmp      :TBitmap;
  TmpJpg      :TJpegImage;
  TmpPNG      :TPortableNetworkGraphic;
  TmpOut      :TJpegImage;
  TmpGif      :TGIFImage;
  TmpInput    :TGraphic;
  K           :Double;
  TmpLeft,
  TmpTop,
  TmpHeight,
  TmpWidth    :integer;
  GetCorrect  :boolean;
begin
  GetCorrect     :=false;
  TempFile       :='';
  TempImgFile    :=sysutils.IncludeTrailingPathDelimiter(FTempFolder)+'_temp';

  ....

  if (not FileExistsUTF8(TmpInFilename))or(not GetCorrect) then
  begin
    Application.MessageBox(pchar('Не найден файл данных'), pchar(caption), MB_ICONINFORMATION+mb_applmodal);
    exit;
  end;

  try

  TmpInput:=nil;
  TmpJpg  :=nil;
  TmpPNG  :=nil;
  TmpBmp  :=nil;
  TmpOut  :=TJpegImage.Create;
  s1      :=TmpInFilename;
  s1      :=ExtractFileExt(s1);

  TmpOut.SetSize(OUTSIZE_W, OUTSIZE_H);
  TmpOut.Canvas.Brush.Color :=clWhite;
  TmpOut.Canvas.Pen.Color   :=clWhite;
  TmpOut.Canvas.FillRect(Rect(0, 0, OUTSIZE_W, OUTSIZE_H));

  s1:=UTF8LowerCase(s1);

  if UTF8Pos(s1, '.bmp',1)>0 then
  begin
    TmpBmp   :=TBitmap.Create;
    TmpInput :=TmpBmp;
  end
  else if UTF8Pos(s1, '*.jpeg;*.jpg;*.jpe;*.jfif',1)>0 then
  begin
    TmpJpg   :=TJpegImage.Create;
    TmpInput :=TmpJpg;
  end
  else if UTF8Pos(s1, '.png',1)>0 then
  begin
     TmpPNG   :=TPortableNetworkGraphic.Create;
     TmpInput :=TmpPNG;
     ExcludeAlphaChanelFromPNGPicture(TmpPNG ,false);
  end
  else if UTF8Pos(s1, '.gif',1)>0 then
  begin
     TmpGif   :=TGIFImage.Create;
     TmpInput :=TmpGif;
     //todo: ExcludeAlphaChanelFromGIFPicture(TmpGif ,false);
  end;

  if Assigned(TmpInput) then
  begin
    TmpInput.LoadFromFile(TmpInFilename);

    if (TmpInput.Height>OUTSIZE_H)and(TmpInput.Width>OUTSIZE_W)then
    begin
        k         :=TmpInput.Height/TmpInput.Width;
        TmpHeight :=Trunc(OUTSIZE_H*K);
        TmpTop    :=(OUTSIZE_H-TmpHeight) div 2;
        TmpWidth  :=OUTSIZE_W;
        TmpOut.Canvas.StretchDraw(Rect(0,
                                       TmpTop,
                                       TmpWidth,
                                       TmpHeight+TmpTop),
                                       TmpInput);
    end
    else if (TmpInput.Height>OUTSIZE_H)and(TmpInput.Width<=OUTSIZE_W)then
    begin
        k         :=TmpInput.Width/TmpInput.Height;
        TmpWidth  :=Trunc(OUTSIZE_W*K);
        TmpLeft   :=(OUTSIZE_W-TmpWidth) div 2;
        TmpHeight :=OUTSIZE_H;
        TmpOut.Canvas.StretchDraw(Rect(TmpLeft,
                                       0,
                                       TmpWidth+TmpLeft,
                                       TmpHeight),
                                       TmpInput);
    end
    else if (TmpInput.Height<=OUTSIZE_H)and(TmpInput.Width>OUTSIZE_W)then
    begin
        k         :=TmpInput.Height/TmpInput.Width;
        TmpHeight :=Trunc(OUTSIZE_H*K);
        TmpTop    :=(OUTSIZE_H-TmpHeight) div 2;
        TmpWidth  :=OUTSIZE_W;
        TmpOut.Canvas.StretchDraw(Rect(0,
                                       TmpTop,
                                       TmpWidth,
                                       TmpHeight+TmpTop),
                                       TmpInput);
    end
    else if (TmpInput.Height<=OUTSIZE_H)and(TmpInput.Width<=OUTSIZE_W)then
    begin
        TmpOut.SetSize(TmpInput.Width, TmpInput.Height);
        TmpOut.Canvas.StretchDraw(Rect(0,0,
                                       TmpInput.Width,
                                       TmpInput.Height),
                                       TmpInput);
    end;
  end;

  s1:=FTmpOutFilename;
  TmpOut.SaveToFile(s1); //FTmpOutFilename
  TmpOut.Free;

  if TempFile<>'' then
   DeleteFileUTF8(TempFile);

  if Assigned(TmpInput) then
    TmpInput.Free;

  Close;
  ModalResult:=mrOk;

  except
    if Assigned(TmpOut) then
    TmpOut.Free;

    if Assigned(TmpInput) then
    TmpInput.Free;

    Close;
    ModalResult:=mrCancel;
  end;

end;


[Alex2013]

Я делал так. Задача взять картинку и уменьшить до максимально допустимого размера.

В принципе тоже самое, что и у меня, но моя задача показать стандартно пропорционально "отмасштабированную" картинку в максимально возможном окне, без черных(или белых) полос сверху или снизу и при этом сохранить возможность менять размер окна "вручную".

По идее это должно делается "в одно действие" просто подстройка размера окна "под содержимое".
(Что-то вроде опции AutoSize ).

Единственное, что приходит в голову ( кроме моей "кракозябры" ) это отказаться от автоматического пропорционального масштабирования картинки и вычислить размер окна самостоятельно .

Код: Выделить всё

procedure TForm1.Button1Click(Sender: TObject);
Const FV:Tform=Nil;
      Im:TImage=Nil;
Var  SW,SH:Integer;
begin
//Создаю форму и картинку
If FV=nil Then begin
FV:=Tform.Create(Self);
Fv.Top := 0;Fv.Left:=0;
Im:= TImage.Create(FV);
Im.Align:=alClient;
Im.Center := True;
Im.Stretch:=True;
//Im.Proportional:=True; Выкидываю ! Точнее переношу  в конец процедуры
FV.InsertControl(Im);
FV.Color:=LeftPanel.Color;
Fv.OnKeyDown:=@FV_FormKeyDown;// для закрытия по ESC
End;

Im.Picture.Bitmap.SetSize(1,1);
//  Im.Picture.Clear;  делает что-то не хорошее при повторном вызове .

// Гружу картинку
If Image3.Picture.Bitmap<>Nil then begin
Im.Picture.Bitmap.Assign(Image1.Picture.Bitmap);


SW:=Screen.Width;
SH:=Screen.Height-100;

// Пропорциональное масштабирование окна в "ручном режиме".
With  im.Picture.Bitmap do
if (Height >SH) and (Width > SW ) then
begin
fv.Width := (SH * Width) div Height;
fv.Height:= (SW * Height) div Width;
end else begin
if Width > SW then begin
       fv.Width := SW;
       fv.Height:= (SW * Height) div Width;
     end;
if Height > SH then
begin
       fv.Width := (SH * Width) div Height;
       fv.Height := SH;
     end;
end;
end;
Im.Proportional:=True;
FV.Show;
End;
end;


Так чуть красивей, но все равно есть ощущение "совы на глобусе".
(Логику можно еще немного оптимизировать, но все равно идея в том, что при наличии готовой опции Proportional все это классическое "изобретение велосипеда" )