In Delphi - I need an algorithm to resample a BitMap to thumbnail size - BiLinear preferred

An old code but the same idea:
http://efg2.com/Lab/Library/Delphi/Graphics/ImageProcessing.htm#Resampling

Probably you should give this component a try:
http://plsoft.users.btopenworld.com/

If you want to avoid granularity and strange effects when you downsize an Image, you should always filter out all the higher frequencies that will no longer fit into the smaller image area... Removing higher frequencies in an image basically means that you "blur" the image...

Since I like image processing, I took some time to make a small sample for you how this can be made...

Run the sample code and then resize the window... If you make the window small enough you will see the aliasing effects on the unfiltered image, where the higher frequencies no longer fit in the image, which makes the downsized image distorted...

If you then mark the checkbox (which tells the application to show the filtered image instead), you'll see the difference with the Anti aliasing effect enabled...

Hope this helps...

/Hypo

object Form5: TForm5
  Left = 0
  Top = 0
  Caption = 'Form5'
  ClientHeight = 551
  ClientWidth = 527
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnPaint = FormPaint
  OnResize = FormResize
  DesignSize = (
    527
    551)
  PixelsPerInch = 96
  TextHeight = 13
  object Bevel1: TBevel
    Left = 8
    Top = 31
    Width = 512
    Height = 512
    Anchors = [akLeft, akTop, akRight, akBottom]
  end
  object CheckBox1: TCheckBox
    Left = 8
    Top = 8
    Width = 97
    Height = 17
    Caption = 'Filterscale'
    TabOrder = 0
    OnClick = CheckBox1Click
  end
end

Select allOpen in new window

unit Unit5;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Math;

type
  TForm5 = class(TForm)
    Bevel1: TBevel;
    CheckBox1: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FOriginalBitmap : TBitmap;
    FScaledBitmap : TBitmap;
    procedure ScaleBitmap(ASource, ATarget : TBitmap; AWidth, AHeight : integer);
  end;

var
  Form5: TForm5;

implementation

{$R *.dfm}


procedure TForm5.FormCreate(Sender: TObject);
var x, y, v : integer;
    r, g, b : Byte;
    d : double;
begin
  FScaledBitmap := TBitmap.Create;
  FScaledBitmap.PixelFormat := pf32bit;
  // Generate the sourceimage...
  FOriginalBitmap := TBitmap.Create;
  FOriginalBitmap.SetSize(512, 512);
  FOriginalBitmap.PixelFormat := pf32bit;
  for y := 0 to 511 do
    for x := 0 to 511 do begin
      // Calculate color for circular pattern...
      d := Sqrt(Sqr(256-X)+Sqr(256-Y));
      v := Trunc(128 + 127*Sin(d));
      r := v;
      g := v;
      b := v;
      // Add chessboard pattern...
      if ((x and 32) <> 0) xor ((y and 32) <> 0) then begin
        R := 0;
        G := 0;
      end;
      // Set the pixel...
      FOriginalBitmap.Canvas.Pixels[X, Y] := RGB(R, G, B);
    end;
end;

procedure TForm5.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FOriginalBitmap);
  FreeAndNil(FScaledBitmap);
end;

procedure TForm5.CheckBox1Click(Sender: TObject);
begin
  Repaint;
end;

procedure TForm5.FormPaint(Sender: TObject);
begin
  if CheckBox1.Checked
    then Canvas.StretchDraw(Bevel1.BoundsRect, FScaledBitmap)
    else Canvas.StretchDraw(Bevel1.BoundsRect, FOriginalBitmap);
end;

procedure TForm5.FormResize(Sender: TObject);
begin
  ScaleBitmap(FOriginalBitmap, FScaledBitmap, Bevel1.Width, Bevel1.Height);
end;

procedure TForm5.ScaleBitmap(ASource, ATarget: TBitmap; AWidth, AHeight : Integer);
var X, Y, sX, sY, tX, tY : integer;
    wScale, hScale : Double;
    aColor : TColor;
    R, G, B : Byte;
    aIndex : integer;
    fX, fY : Double;
    d : double;
    aResult : array of single;
begin
  if (AWidth > 0) and (AHeight > 0) then begin
    SetLength(aResult, AWidth*AHeight * 4);
    try
      wScale := AWidth / ASource.Width;
      hScale := AHeight / ASource.Height;
      for Y := 0 to ASource.Width-1 do begin
        fY := Y * hScale;
        tY := Round(fY);
        for X := 0 to ASource.Height-1 do begin
          fX := X * wScale;  // fX & fY contains the float coordinate to ATarget...
          tX := Round(fX);   // tX & tY contains the integer center-coordinate to ATarget...
          // get Color-components...
          aColor := ASource.Canvas.Pixels[X, Y];
          R := GetRValue(aColor);
          G := GetGValue(aColor);
          B := GetBValue(aColor);
          // Process each pixel and it's surroundings...
          for sY := -1 to 1 do begin
            if (tY + sY >= 0) and (tY + sY < AHeight) then
              for sX := -1 to 1 do begin
                if (tX + sX >= 0) and (tX + sX < AWidth) then begin
                  aIndex := (tY + sY) * AWidth + tX + sX;
                  d := Sqrt(Sqr(fX - (tX + sX)) + Sqr(fY - (tY + sY)));
                  // d contains the distance to the pixel...
                  if d < 1 then begin
                    aResult[aIndex * 4 + 0] := aResult[aIndex * 4 + 0] + R * (1-d);
                    aResult[aIndex * 4 + 1] := aResult[aIndex * 4 + 1] + G * (1-d);
                    aResult[aIndex * 4 + 2] := aResult[aIndex * 4 + 2] + B * (1-d);
                    aResult[aIndex * 4 + 3] := aResult[aIndex * 4 + 3] + (1-d);
                  end;
                end;
              end;
          end;
        end;
      end;
      ATarget.SetSize(AWidth, AHeight);
      for Y := 0 to AHeight-1 do begin
        for X := 0 to AWidth-1 do begin
          aIndex := Y * AWidth + X;
          d := aResult[aIndex * 4 + 3];
          if d <> 0 then begin
            R := Trunc(aResult[aIndex * 4 + 0] / d);
            G := Trunc(aResult[aIndex * 4 + 1] / d);
            B := Trunc(aResult[aIndex * 4 + 2] / d);
            ATarget.Canvas.Pixels[X, Y] := RGB(R, G, B);
          end;
        end;
      end;
    finally
      aResult := nil;
    end;
  end;
end;


end.

Select allOpen in new window

Thank Hypo!

I tried your code and i compared thumbnails to my previous algorithm. And it looks like yours are coming out much better.

Awesome

The only thing is, I seem to get white bars on my resultant images. I think I might be sending bad data to the AWidth, AHeight variables.

but i'm not sure...

I'm so unskilled about such things...

Do you think you could tweak your algo to accept 2 variables - e.g. to have the same 2 variables as input as the algo I listed at the top of this post?

procedure SmoothResize(Src, Dst: TBitmap);

I would forever thankful!!!

Sure... one thing about the algorithm I wrote is that it's written to scale down images... If you scale up the images it gives bad results right now... but I'll modify the code as to how you want it....

Looking at your code, I assume that you set Width and Height of the Dst bitmap before you call the SmoothResize function... so the Src image will be scaled down to whatever size Dst image is, correct?

Ok,
so I've modified the function somewhat... do the results look ok for you now?

/Hypo

procedure SmoothScale(Src, Dst : TBitmap);
var X, Y, sX, sY, tX, tY : integer;
    wScale, hScale : Double;
    aColor : TColor;
    R, G, B : Byte;
    aIndex, aWidth, aHeight : integer;
    fX, fY : Double;
    d : double;
    aResult : array of single;
begin
  aWidth := Dst.Width;
  aHeight := Dst.Height;
  if (aWidth > 0) and (aHeight > 0) then begin
    wScale := aWidth / Src.Width;
    hScale := aHeight / Src.Height;
    if (wScale >= 1) or (hScale >= 1) then begin
      Dst.Canvas.StretchDraw(Rect(0, 0, aWidth, aHeight), Src);
    end;
    if (wScale < 1) or (hScale < 1) then begin
      SetLength(aResult, aWidth*aHeight * 4);
      try
        for Y := 0 to Src.Width-1 do begin
          fY := Y * hScale;
          tY := Round(fY);
          for X := 0 to Src.Height-1 do begin
            fX := X * wScale;  // fX & fY contains the float coordinate to Dst...
            tX := Round(fX);   // tX & tY contains the integer center-coordinate to Dst...
            // get Color-components...
            aColor := Src.Canvas.Pixels[X, Y];
            R := GetRValue(aColor);
            G := GetGValue(aColor);
            B := GetBValue(aColor);
            // Process each pixel and it's surroundings...
            for sY := -1 to 1 do begin
              if (tY + sY >= 0) and (tY + sY < aHeight) then
                for sX := -1 to 1 do begin
                  if (tX + sX >= 0) and (tX + sX < aWidth) then begin
                    aIndex := (tY + sY) * aWidth + tX + sX;
                    d := Sqrt(Sqr(fX - (tX + sX)) + Sqr(fY - (tY + sY)));
                    // d contains the distance to the pixel...
                    if d < 1 then begin
                      aResult[aIndex * 4 + 0] := aResult[aIndex * 4 + 0] + R * (1-d);
                      aResult[aIndex * 4 + 1] := aResult[aIndex * 4 + 1] + G * (1-d);
                      aResult[aIndex * 4 + 2] := aResult[aIndex * 4 + 2] + B * (1-d);
                      aResult[aIndex * 4 + 3] := aResult[aIndex * 4 + 3] + (1-d);
                    end;
                  end;
                end;
            end;
          end;
        end;
        for Y := 0 to aHeight-1 do begin
          for X := 0 to aWidth-1 do begin
            aIndex := Y * aWidth + X;
            d := aResult[aIndex * 4 + 3];
            if d <> 0 then begin
              R := Trunc(aResult[aIndex * 4 + 0] / d);
              G := Trunc(aResult[aIndex * 4 + 1] / d);
              B := Trunc(aResult[aIndex * 4 + 2] / d);
              Dst.Canvas.Pixels[X, Y] := RGB(R, G, B);
            end;
          end;
        end;
      finally
        aResult := nil;
      end;
    end;
  end;
end;

Select allOpen in new window

Thanks man

I plugged in your above code and the program did indeed run.

but it still seems to be cropping the images in a weird fashion: - e.g. inserting white bars

You can see an example of a pic i tried to resize here:

http://img98.imageshack.us/img98/9400/whyoriginal.jpg
http://img23.imageshack.us/img23/1319/whyresult.jpg

ya there isnt anything too exotic about the new bitmap. Heres the code i use to call it.

NewBitmap := TBitmap.Create;
NewBitmap.Width  := MyNewWidth;
NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width);

The program still works fine with my originally quoted algorithm.

So this leads me to believe that there is some math error somewhere that is knockin the canvas over for some reason????

Thanks!!!

Following this thread. Good stuff here Hypo.

Thx Thieving,
It's just a rough piece of code I threw together... but still, I love these kinds of problems... :)

woo hoo - thanks so much - it works great! - Cr*p i wish i was that smart! thanks!!!!