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

Previous  Top  Next

    
 

 

Code:

// This function stretches a bitmap with specified number of pixels

// in horizontal, vertical dimension

// Example Call : ResizeBmp(Image1.Picture.Bitmap , 200 , 200);

 

function TForm1.ResizeBmp(bitmp: TBitmap; wid, hei: Integer): Boolean;

var

   TmpBmp: TBitmap;

  ARect: TRect;

begin

  Result := False;

  try

    TmpBmp := TBitmap.Create;

    try

      TmpBmp.Width  := wid;

      TmpBmp.Height := hei;

      ARect := Rect(0,0, wid, hei);

      TmpBmp.Canvas.StretchDraw(ARect, Bitmp);

      bitmp.Assign(TmpBmp);

    finally

      TmpBmp.Free;

    end;

    Result := True;

  except

    Result := False;

  end;

end;

©Drkb::03835


Code:

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.

©Drkb::03836

Взято с сайта: http://www.swissdelphicenter.ch