Растягивание изображения

Delphi , Графика и Игры , Изображения

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

unit DeleteScans;
 //Renate Schaaf 
//renates@xmission.com 

interface

 uses Windows, Graphics;

 procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
   //scanline implementation of Stretchblt/Delete_Scans 
  //about twice as fast 
  //Stretches Src to Dest, rs is source rect, rd is dest. rect 
  //The stretch is centered, i.e the center of rs is mapped to the center of rd. 
  //Src, Dest are assumed to be bottom up 

implementation

 uses Classes, math;

 type
   TRGBArray = array[0..64000] of TRGBTriple;
   PRGBArray = ^TRGBArray;

   TQuadArray = array[0..64000] of TRGBQuad;
   PQuadArray = ^TQuadArray;

 procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
 var
    xsteps, ysteps: array of Integer;
   intscale: Integer;
   i, x, y, x1, x2, bitspp, bytespp: Integer;
   ts, td: PByte;
   bs, bd, WS, hs, w, h: Integer;
   Rows, rowd: PByte;
   j, c: Integer;
   pf: TPixelFormat;
   xshift, yshift: Integer;
 begin
   WS := rs.Right - rs.Left;
   hs := rs.Bottom - rs.Top;
   w  := rd.Right - rd.Left;
   h  := rd.Bottom - rd.Top;
   pf := Src.PixelFormat;
   if (pf <> pf32Bit) and (pf <> pf24bit) then
   begin
     pf := pf24bit;
     Src.PixelFormat := pf;
   end;
   Dest.PixelFormat := pf;
   if not (((w <= WS) and (h <= hs)) or ((w >= WS) and (h >= hs))) then
   //we do not handle a mix of up-and downscaling, 
  //using threadsafe StretchBlt instead. 
  begin
     Src.Canvas.Lock;
     Dest.Canvas.Lock;
     try
       SetStretchBltMode(Dest.Canvas.Handle, STRETCH_DELETESCANS);
       StretchBlt(Dest.Canvas.Handle, rd.Left, rd.Top, w, h,
         Src.Canvas.Handle, rs.Left, rs.Top, WS, hs, SRCCopy);
     finally
       Dest.Canvas.Unlock;
       Src.Canvas.Unlock;
     end;
     Exit;
   end;

   if pf = pf24bit then
   begin
     bitspp  := 24;
     bytespp := 3;
   end
   else
   begin
     bitspp  := 32;
     bytespp := 4;
   end;
   bs := (Src.Width * bitspp + 31) and not 31;
   bs := bs div 8; //BytesPerScanline Source 
  bd := (Dest.Width * bitspp + 31) and not 31;
   bd := bd div 8; //BytesPerScanline Dest 
  if w < WS then //downsample 
  begin
     //first make arrays of the skipsteps 
    SetLength(xsteps, w);
     SetLength(ysteps, h);
     intscale := round(WS / w * $10000);
     x1       := 0;
     x2       := (intscale + $7FFF) shr 16;
     c  := 0;
     for i := 0 to w - 1 do
     begin
       xsteps[i] := (x2 - x1) * bytespp;
       x1        := x2;
       x2        := ((i + 2) * intscale + $7FFF) shr 16;
       if i = w - 2 then
         c := x1;
     end;
     xshift   := min(max((WS - c) div 2, - rs.Left), Src.Width - rs.Right);
     intscale := round(hs / h * $10000);
     x1       := 0;
     x2       := (intscale + $7FFF) shr 16;
     c        := 0;
     for i := 0 to h - 1 do
     begin
       ysteps[i] := (x2 - x1) * bs;
       x1        := x2;
       x2        := ((i + 2) * intscale + $7FFF) shr 16;
       if i = h - 2 then
         c := x1;
     end;
     yshift := min(max((hs - c) div 2, - rs.Top), Src.Height - rs.Bottom);
     if pf = pf24bit then
     begin
       Rows := @PRGBArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
       rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
       for y := 0 to h - 1 do
       begin
         ts := Rows;
         td := rowd;
         for x := 0 to w - 1 do
         begin
           pRGBTriple(td)^ := pRGBTriple(ts)^;
           Inc(td, bytespp);
           Inc(ts, xsteps[x]);
         end;
         Dec(rowd, bd);
         Dec(Rows, ysteps[y]);
       end;
     end
     else
     begin
       Rows := @PQuadArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
       rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
       for y := 0 to h - 1 do
       begin
         ts := Rows;
         td := rowd;
         for x := 0 to w - 1 do
         begin
           pRGBQuad(td)^ := pRGBQuad(ts)^;
           Inc(td, bytespp);
           Inc(ts, xsteps[x]);
         end;
         Dec(rowd, bd);
         Dec(Rows, ysteps[y]);
       end;
     end;
   end
   else
   begin
     //first make arrays of the steps of uniform pixels 
    SetLength(xsteps, WS);
     SetLength(ysteps, hs);
     intscale := round(w / WS * $10000);
     x1       := 0;
     x2       := (intscale + $7FFF) shr 16;
     c        := 0;
     for i := 0 to WS - 1 do
     begin
       xsteps[i] := x2 - x1;
       x1        := x2;
       x2        := ((i + 2) * intscale + $7FFF) shr 16;
       if x2 > w then
         x2 := w;
       if i = WS - 1 then
         c := x1;
     end;
     if c < w then //>is now not possible 
    begin
       xshift         := (w - c) div 2;
       yshift         := w - c - xshift;
       xsteps[WS - 1] := xsteps[WS - 1] + xshift;
       xsteps[0]      := xsteps[0] + yshift;
     end;
     intscale := round(h / hs * $10000);
     x1       := 0;
     x2       := (intscale + $7FFF) shr 16;
     c        := 0;
     for i := 0 to hs - 1 do
     begin
       ysteps[i] := (x2 - x1);
       x1        := x2;
       x2        := ((i + 2) * intscale + $7FFF) shr 16;
       if x2 > h then
         x2 := h;
       if i = hs - 1 then
         c := x1;
     end;
     if c < h then
     begin
       yshift         := (h - c) div 2;
       ysteps[hs - 1] := ysteps[hs - 1] + yshift;
       yshift         := h - c - yshift;
       ysteps[0]      := ysteps[0] + yshift;
     end;
     if pf = pf24bit then
     begin
       Rows := @PRGBArray(Src.Scanline[rs.Top])^[rs.Left];
       rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
       for y := 0 to hs - 1 do
       begin
         for j := 1 to ysteps[y] do
         begin
           ts := Rows;
           td := rowd;
           for x := 0 to WS - 1 do
           begin
             for i := 1 to xsteps[x] do
             begin
               pRGBTriple(td)^ := pRGBTriple(ts)^;
               Inc(td, bytespp);
             end;
             Inc(ts, bytespp);
           end;
           Dec(rowd, bd);
         end;
         Dec(Rows, bs);
       end;
     end
     else
     begin
       Rows := @PQuadArray(Src.Scanline[rs.Top])^[rs.Left];
       rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
       for y := 0 to hs - 1 do
       begin
         for j := 1 to ysteps[y] do
         begin
           ts := Rows;
           td := rowd;
           for x := 0 to WS - 1 do
           begin
             for i := 1 to xsteps[x] do
             begin
               pRGBQuad(td)^ := pRGBQuad(ts)^;
               Inc(td, bytespp);
             end;
             Inc(ts, bytespp);
           end;
           Dec(rowd, bd);
         end;
         Dec(Rows, bs);
       end;
     end;
   end;
 end;


 end.

Программный код на языке Delphi для обработки изображений, конкретно для масштабирования (растяжения) изображения из одной разрешающей способности в другую, сохраняя соотношение сторон. Код использует два массива xsteps и ysteps, чтобы хранить шаги для каждого пикселя в направлении x и y соответственно.

Алгоритм сначала проверяет, имеет ли исходное изображение формат 24-бита или 32-бита, и если так, то конвертирует его в формат 24-бита для обработки. Затем он рассчитывает количество пикселей на строку (bs) и байты на строку (bd) для обоих исходного и целевого изображений.

Если целевое изображение меньше исходного (downsampling), код рассчитывает шаги xsteps и ysteps, основываясь на коэффициентах масштабирования, и затем копирует пиксели из исходного изображения в целевое изображение с помощью этих шагов. Если целевое изображение больше исходного (upsampling), код использует другой набор шагов, рассчитанных на основе коэффициентов масштабирования.

Код также обрабатывает случаи, когда исходное изображение имеет формат пикселей, отличный от 24-бита или 32-бита, конвертируя его в один из этих форматов перед обработкой. Он также использует функцию SetStretchBltMode для включения режима растяжения для канваса целевого изображения и затем вызывает функцию StretchBlt, чтобы выполнить операцию растяжения.

Некоторые предложения по улучшению кода:

1. Добавьте комментарии, объясняющие, что делает каждая часть кода.
2. Рассмотрите использование более описательных имен переменных, чтобы сделать код более читаемым.
3. Используйте константы вместо магических чисел (например, 24, 32) для представления форматов пикселей и других значений, используемых в нескольких местах.
4. Рассмотрите использование отдельной функции для логики downsampling и upscaling, чтобы сделать код более модульным и легко поддерживаемым.
5. Добавьте обработку ошибок, чтобы обрабатывать случаи, когда исходное или целевое изображения недействительно или не может быть обработано.

В целом, это сложный код, требующий тщательного понимания обработки изображений и программирования на языке Delphi.

Растягивание изображения с помощью алгоритма DeleteScansRect в Delphi.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Изображения ::