Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Растягивание изображения

Оформил: 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 World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.