jvqresample.pas

East make Tray Icon in delphi

procedure ImgStretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);
var
  XScale, YScale: Single; // Zoom scale factors
  I, J, K: Integer; // Loop variables
  Center: Single; // Filter calculation variables
  Width, FScale, Weight: Single; // Filter calculation variables
  Left, Right: Integer; // Filter calculation variables
  N: Integer; // Pixel number
  Work: TBitmap;
  Contrib: PCListList;
  Rgb: TRGB;
  Color: TColorRGB;
  SourceLine, DestLine: PRGBList;
  SourcePixel, DestPixel: PColorRGB;
  Delta, DestDelta: Integer;
  SrcWidth, SrcHeight, DstWidth, DstHeight: Integer;

  function Color2RGB(Color: TColor): TColorRGB;
  begin
    Result.R := Color and $000000FF;
    Result.G := (Color and $0000FF00) shr 8;
    Result.B := (Color and $00FF0000) shr 16;
  end;

  function RGB2Color(Color: TColorRGB): TColor;
  begin
    Result := Color.R or (Color.G shl 8) or (Color.B shl 16);
  end;

begin
  DstWidth := Dst.Width;
  DstHeight := Dst.Height;
  SrcWidth := Src.Width;
  SrcHeight := Src.Height;
  if (SrcWidth < 1) or (SrcHeight < 1) then
    raise EJVCLException.CreateRes(@RsESourceBitmapTooSmall);

  // Create intermediate image to hold horizontal zoom
  Work := TBitmap.Create;
  try
    Work.Height := SrcHeight;
    Work.Width := DstWidth;
    // XScale := DstWidth / SrcWidth;
    // YScale := DstHeight / SrcHeight;
    // Improvement suggested by David Ullrich:
    if SrcWidth = 1 then
      XScale := DstWidth / SrcWidth
    else
      XScale := (DstWidth - 1) / (SrcWidth - 1);
    if SrcHeight = 1 then
      YScale := DstHeight / SrcHeight
    else
      YScale := (DstHeight - 1) / (SrcHeight - 1);
    // This implementation only works on 24-bit images because it uses
    // TBitmap.Scanline
    Src.PixelFormat := pf24bit;
    Dst.PixelFormat := Src.PixelFormat;
    Work.PixelFormat := Src.PixelFormat;

    // --------------------------------------------
    // Pre-calculate filter contributions for a row
    // -----------------------------------------------
    GetMem(Contrib, DstWidth * SizeOf(TCList));
    // Horizontal sub-sampling
    // Scales from bigger to smaller Width
    if XScale < 1.0 then
    begin
      Width := AWidth / XScale;
      FScale := 1.0 / XScale;
      for I := 0 to DstWidth - 1 do
      begin
        Contrib^[I].N := 0;
        GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));
        Center := I / XScale;
        // Original code:
        // Left := Ceil(Center - Width);
        // Right := Floor(Center + Width);
        Left := Floor(Center - Width);
        Right := Ceil(Center + Width);
        for J := Left to Right do
        begin
          Weight := Filter((Center - J) / FScale) / FScale;
          if Weight = 0.0 then
            Continue;
          if J < 0 then
            N := -J
          else
          if J >= SrcWidth then
            N := SrcWidth - J + SrcWidth - 1
          else
            N := J;
          K := Contrib^[I].N;
          Contrib^[I].N := Contrib^[I].N + 1;
          Contrib^[I].P^[K].Pixel := N;
          Contrib^[I].P^[K].Weight := Weight;
        end;
      end;
    end
    else
      // Horizontal super-sampling
      // Scales from smaller to bigger Width
    begin
      for I := 0 to DstWidth - 1 do
      begin
        Contrib^[I].N := 0;
        GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));
        Center := I / XScale;
        // Original code:
        // Left := Ceil(Center - AWidth);
        // Right := Floor(Center + AWidth);
        Left := Floor(Center - AWidth);
        Right := Ceil(Center + AWidth);
        for J := Left to Right do
        begin
          Weight := Filter(Center - J);
          if Weight = 0.0 then
            Continue;
          if J < 0 then
            N := -J
          else
          if J >= SrcWidth then
            N := SrcWidth - J + SrcWidth - 1
          else
            N := J;
          K := Contrib^[I].N;
          Contrib^[I].N := Contrib^[I].N + 1;
          Contrib^[I].P^[K].Pixel := N;
          Contrib^[I].P^[K].Weight := Weight;
        end;
      end;
    end;

    // ----------------------------------------------------
    // Apply filter to sample horizontally from Src to Work
    // ----------------------------------------------------
    for K := 0 to SrcHeight - 1 do
    begin
      SourceLine := Src.ScanLine[K];
      DestPixel := Work.ScanLine[K];
      for I := 0 to DstWidth - 1 do
      begin
        Rgb.R := 0.0;
        Rgb.G := 0.0;
        Rgb.B := 0.0;
        for J := 0 to Contrib^[I].N - 1 do
        begin
          Color := SourceLine^[Contrib^[I].P^[J].Pixel];
          Weight := Contrib^[I].P^[J].Weight;
          if Weight = 0.0 then
            Continue;
          Rgb.R := Rgb.R + Color.R * Weight;
          Rgb.G := Rgb.G + Color.G * Weight;
          Rgb.B := Rgb.B + Color.B * Weight;
        end;
        if Rgb.R > 255.0 then
          Color.R := 255
        else
        if Rgb.R < 0.0 then
          Color.R := 0
        else
          Color.R := Round(Rgb.R);
        if Rgb.G > 255.0 then
          Color.G := 255
        else
        if Rgb.G < 0.0 then
          Color.G := 0
        else
          Color.G := Round(Rgb.G);
        if Rgb.B > 255.0 then
          Color.B := 255
        else
        if Rgb.B < 0.0 then
          Color.B := 0
        else
          Color.B := Round(Rgb.B);
        // Set new Pixel value
        DestPixel^ := Color;
        // Move on to next column
        Inc(DestPixel);
      end;
    end;

    // Free the memory allocated for horizontal filter weights
    for I := 0 to DstWidth - 1 do
      FreeMem(Contrib^[I].P);

    FreeMem(Contrib);

    // -----------------------------------------------
    // Pre-calculate filter contributions for a column
    // -----------------------------------------------
    GetMem(Contrib, DstHeight * SizeOf(TCList));
    // Vertical sub-sampling
    // Scales from bigger to smaller height
    if YScale < 1.0 then
    begin
      Width := AWidth / YScale;
      FScale := 1.0 / YScale;
      for I := 0 to DstHeight - 1 do
      begin
        Contrib^[I].N := 0;
        GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));
        Center := I / YScale;
        // Original code:
        // Left := Ceil(Center - Width);
        // Right := Floor(Center + Width);
        Left := Floor(Center - Width);
        Right := Ceil(Center + Width);
        for J := Left to Right do
        begin
          Weight := Filter((Center - J) / FScale) / FScale;
          if Weight = 0.0 then
            Continue;
          if J < 0 then
            N := -J
          else
          if J >= SrcHeight then
            N := SrcHeight - J + SrcHeight - 1
          else
            N := J;
          K := Contrib^[I].N;
          Contrib^[I].N := Contrib^[I].N + 1;
          Contrib^[I].P^[K].Pixel := N;
          Contrib^[I].P^[K].Weight := Weight;
        end;
      end
    end
    else
      // Vertical super-sampling
      // Scales from smaller to bigger height
    begin
      for I := 0 to DstHeight - 1 do
      begin
        Contrib^[I].N := 0;
        GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));
        Center := I / YScale;
        // Original code:
        // Left := Ceil(Center - AWidth);
        // Right := Floor(Center + AWidth);
        Left := Floor(Center - AWidth);
        Right := Ceil(Center + AWidth);
        for J := Left to Right do
        begin
          Weight := Filter(Center - J);
          if Weight = 0.0 then
            Continue;
          if J < 0 then
            N := -J
          else
          if J >= SrcHeight then
            N := SrcHeight - J + SrcHeight - 1
          else
            N := J;
          K := Contrib^[I].N;
          Contrib^[I].N := Contrib^[I].N + 1;
          Contrib^[I].P^[K].Pixel := N;
          Contrib^[I].P^[K].Weight := Weight;
        end;
      end;
    end;

    // --------------------------------------------------
    // Apply filter to sample vertically from Work to Dst
    // --------------------------------------------------
    SourceLine := Work.ScanLine[0];
    Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
    DestLine := Dst.ScanLine[0];
    DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
    for K := 0 to DstWidth - 1 do
    begin
      DestPixel := Pointer(DestLine);
      for I := 0 to DstHeight - 1 do
      begin
        Rgb.R := 0;
        Rgb.G := 0;
        Rgb.B := 0;
        // Weight := 0.0;
        for J := 0 to Contrib^[I].N - 1 do
        begin
          Color := PColorRGB(Integer(SourceLine) + Contrib^[I].P^[J].Pixel * Delta)^;
          Weight := Contrib^[I].P^[J].Weight;
          if Weight = 0.0 then
            Continue;
          Rgb.R := Rgb.R + Color.R * Weight;
          Rgb.G := Rgb.G + Color.G * Weight;
          Rgb.B := Rgb.B + Color.B * Weight;
        end;
        if Rgb.R > 255.0 then
          Color.R := 255
        else
        if Rgb.R < 0.0 then
          Color.R := 0
        else
          Color.R := Round(Rgb.R);
        if Rgb.G > 255.0 then
          Color.G := 255
        else
        if Rgb.G < 0.0 then
          Color.G := 0
        else
          Color.G := Round(Rgb.G);
        if Rgb.B > 255.0 then
          Color.B := 255
        else
        if Rgb.B < 0.0 then
          Color.B := 0
        else
          Color.B := Round(Rgb.B);
        DestPixel^ := Color;
        Inc(Integer(DestPixel), DestDelta);
      end;
      Inc(SourceLine, 1);
      Inc(DestLine, 1);
    end;

    // Free the memory allocated for vertical filter weights
    for I := 0 to DstHeight - 1 do
      FreeMem(Contrib^[I].P);

    FreeMem(Contrib);
  finally
    Work.Free;
  end;
end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvQResample.pas,v $';
    Revision: '$Revision: 1.16 $';
    Date: '$Date: 2004/09/07 23:11:35 $';
    LogPath: 'JVCL\run'
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.