Solved

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

Posted on 2011-02-17
11
1,035 Views
Last Modified: 2012-05-11
Thanks for reading

I've been using the below algorithm to resample bitmaps in Delphi.

But when it comes to making small thumbnails, it results in grainy images.

Anyone see a good algorithm around to do a better job?  Or do you want to recommend a package to buy?

This is literally the only "image processing" i need so i'd hate to buy a whole package for just one function...

Thanks!

procedure SmoothResize(Src, Dst: TBitmap);
var
x, y: Integer;
xP, yP: Integer;
xP2, yP2: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
Src.PixelFormat := pf24Bit;
Dst.PixelFormat := pf24Bit;

if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
Dst.Assign(Src)
else
begin
DstLine := Dst.ScanLine[0];
DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);

xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
yP := 0;

for y := 0 to pred(Dst.Height) do
begin
xP := 0;

SrcLine1 := Src.ScanLine[yP shr 16];

if (yP shr 16 < pred(Src.Height)) then
SrcLine2 := Src.ScanLine[succ(yP shr 16)]
else
SrcLine2 := Src.ScanLine[yP shr 16];

z2 := succ(yP and $FFFF);
iz2 := succ((not yp) and $FFFF);
for x := 0 to pred(Dst.Width) do
begin
t3 := xP shr 16;
z := xP and $FFFF;
w2 := MulDiv(z, iz2, $10000);
w1 := iz2 - w2;
w4 := MulDiv(z, z2, $10000);
w3 := z2 - w4;
DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
SrcLine1[t3 + 1].rgbtRed * w2 +
SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
DstLine[x].rgbtGreen :=
(SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +

SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;
DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
SrcLine1[t3 + 1].rgbtBlue * w2 +
SrcLine2[t3].rgbtBlue * w3 +
SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
Inc(xP, xP2);
end; {for}
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end; {for}
end; {if}
end;

Open in new window

0
Comment
Question by:bobbysdog
  • 5
  • 3
  • 2
  • +1
11 Comments
 
LVL 24

Expert Comment

by:jimyX
ID: 34919219
0
 
LVL 24

Expert Comment

by:jimyX
ID: 34919287
Probably you should give this component a try:
http://plsoft.users.btopenworld.com/
0
 
LVL 12

Expert Comment

by:Hypo
ID: 34920059
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

Open 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.

Open in new window

0
 

Author Comment

by:bobbysdog
ID: 34921627
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!!!
0
 
LVL 12

Expert Comment

by:Hypo
ID: 34921684
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?
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 12

Expert Comment

by:Hypo
ID: 34921745
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;

Open in new window

0
 

Author Comment

by:bobbysdog
ID: 34921931
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!!!
0
 
LVL 12

Accepted Solution

by:
Hypo earned 500 total points
ID: 34922005
Ahh, I found a bug... I had mixed up Width and Height in the main loop... :)

for Y := 0 to Src.Width-1 do begin // <- this should be Src.Height
  fY := Y * hScale;
  tY := Round(fY);
  for X := 0 to Src.Height-1 do begin // <- this should be Src.Width


I have updated the sample now, please try again... :)

/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.Height-1 do begin
          fY := Y * hScale;
          tY := Round(fY);
          for X := 0 to Src.Width-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;

Open in new window

0
 
LVL 13

Expert Comment

by:ThievingSix
ID: 34922040
Following this thread. Good stuff here Hypo.
0
 
LVL 12

Expert Comment

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

Author Closing Comment

by:bobbysdog
ID: 34922290
woo hoo - thanks so much - it works great! - Cr*p i wish i was that smart! thanks!!!!
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
This Micro Tutorial will give you a basic overview how to record your screen with Microsoft Expression Encoder. This program is still free and open for the public to download. This will be demonstrated using Microsoft Expression Encoder 4.
This is used to tweak the memory usage for your computer, it is used for servers more so than workstations but just be careful editing registry settings as it may cause irreversible results. I hold no responsibility for anything you do to the regist…

863 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

24 Experts available now in Live!

Get 1:1 Help Now