TImage растягивание без масштабирования

[JoLan]

Есть такая картинка:


Нужно превратить её в:


Как можно реализовать подобное?

[SERG1980]

Св-во Strech у имиджа в true

[JoLan]

То ли я не так понял, почитав про Stretch, то ли Вы меня.

Нужно растянуть картинку без искажения, то есть разрезать посередине, отрезанную часть сдвинуть на n пикселей и заполнить разрез шаблоном, взятым из вертикальной полоски в 1 пиксель слева (допустим) от места разреза.

[Аватар]

Ручками программно в канве TImage

[JoLan]

Можно пример или ссылку на ман по Canvas? T_T

З.Ы. На моем Delphi документации нет.

[SERG1980]

procedure TForm1.Button1Click(Sender: TObject);
var b2:TBitMap;
    r1,r2:TRect;
    i,w:integer;
begin
 w:=Round(image1.Width/2);
 r1:=Bounds(0,0,w,image1.Height);
 r2:=Bounds(w,0,image1.Width-w,image1.Height);
 //***********************************************************
 image1.Width:=image1.Width+100;
 b2:=TBitMap.Create;
 b2.Width:=image1.Width;
 b2.Height:=image1.Height;
 b2.Canvas.CopyRect(r1,image1.Picture.Bitmap.Canvas,r1);
 r1:=Bounds(b2.Width-w,0,w,b2.Height);
 b2.Canvas.CopyRect(r1,image1.Picture.Bitmap.Canvas,r2);
 for i:= w to b2.Width-w do
  begin
   r1:=Bounds(i-1,0,1,b2.Height);
   r2:=Bounds(i,0,1,b2.Height);
   b2.Canvas.CopyRect(r2,b2.Canvas,r1);
  end;
 image1.Picture.Assign(b2);
 b2.Free;
end;

[JoLan]

{Кнопки "спасибо" не видно...
Спасибо большое!}

upd: Все работает замечательно, только теперь появилась другая проблема: использую Vampyre Imaging Library, загружаю на форму dds с альфа-каналом. При использовании Canvas он пропадает, т.е. вместо полупрозрачного черного получаю непрозрачный черный.

[SERG1980]

попробуйте вот так, но я не уверен что поможет

......
b2:=TBitMap.Create;
b2.PixelFormat:=pf32bit;
b2.Width:=image1.Width;
.......

[JoLan]

Проблема решена использованием мозгов и документации (полезно иногда, кстати):

uses ImagingTypes, Imaging, ImagingComponents;
...
procedure TForm1.LoadImage(Filestr:String; Wdth,Hght:integer; NeedResize:Boolean);
var Img,Temp,Temp2: TImageData;
    ImgBitmap: TImagingBitmap;
    dynImage:TImage;
    i,w,h,iw,ih,tw,th:integer;
begin
  InitImage(Img);
  LoadImageFromFile(Edit2.Text, Img);
  if NeedResize then begin
    InitImage(Temp);
    NewImage(Wdth,Hght,Img.Format,Temp);
    iw := Img.Width;
    ih := Img.Height;
    tw := Temp.Width;
    th := Temp.Height;
    w := Round(Img.Width/2);
    h := Round(Img.Height/2);
    CopyRect(Img, 0, 0, iw-w, ih-h, Temp, 0, 0);
    CopyRect(Img, w, 0, iw-w, ih-h, Temp, tw-w, 0);
    CopyRect(Img, 0, h, iw-w, ih-h, Temp, 0, th-h);
    CopyRect(Img, w, h, iw-w, ih-h, Temp, tw-w, th-h);
    NewImage(Wdth,Hght,Temp.Format,Temp2);
    CopyRect(Temp,0,0,tw,th,Temp2,0,0);
    for i := 0 to Wdth - iw+1 do CopyRect(Temp2, w-1, 0, 1, th, Temp, w+i, 0);
    CopyRect(Temp,0,0,tw,th,Temp2,0,0);
    for i := 0 to Hght-ih+1 do CopyRect(Temp2, 0, h-1, tw,1, Temp, 0, h+i);
    FreeImage(Temp2);
    ImgBitmap := TImagingBitmap.Create;
    ImgBitmap.AssignFromImageData(Temp);
    FreeImage(Temp);
  end else begin
    ImgBitmap := TImagingBitmap.Create;
    ImgBitmap.AssignFromImageData(Img);
  end;
  dynImage := TImage.Create(Form1);
  dynImage.Parent := ScrollBox1;
  dynImage.Left := 0;
  dynImage.Top := 0;
  dynImage.Width := Wdth;
  dynImage.Height := Hght;
  dynImage.Picture.Graphic := ImgBitmap;
  FreeImage(Img);
end;

Картинка загружается в scrollbox, т.к. важно было увидеть всю картинку без подгонки. Так же в процедуре CopyRect юнита Imaging закомментировал строки:

if OldFormat <> ifUnknown then
ConvertImage(DstImage, OldFormat);

что существенно сократило время перерисовки с 12-14с до ~0.3-0.5 с.

Делал это исключительно для dds и под себя.

Исходная картинка:


Перерисованная:

[kirsan007]

Сообщение от SERG1980

procedure TForm1.Button1Click(Sender: TObject);
var b2:TBitMap;
    r1,r2:TRect;
    i,w:integer;
begin
 w:=Round(image1.Width/2);
 r1:=Bounds(0,0,w,image1.Height);
 r2:=Bounds(w,0,image1.Width-w,image1.Height);
 //***********************************************************
 image1.Width:=image1.Width+100;
 b2:=TBitMap.Create;
 b2.Width:=image1.Width;
 b2.Height:=image1.Height;
 b2.Canvas.CopyRect(r1,image1.Picture.Bitmap.Canvas,r1);
 r1:=Bounds(b2.Width-w,0,w,b2.Height);
 b2.Canvas.CopyRect(r1,image1.Picture.Bitmap.Canvas,r2);
 for i:= w to b2.Width-w do
  begin
   r1:=Bounds(i-1,0,1,b2.Height);
   r2:=Bounds(i,0,1,b2.Height);
   b2.Canvas.CopyRect(r2,b2.Canvas,r1);
  end;
 image1.Picture.Assign(b2);
 b2.Free;
end;

самый непонятный говнокод из всех непонятных говнокодов что я в жизни видел.