Solved

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

Posted on 2011-02-17
11
1,034 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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
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

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

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…
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Illustrator's Shape Builder tool will let you combine shapes visually and interactively. This video shows the Mac version, but the tool works the same way in Windows. To follow along with this video, you can draw your own shapes or download the file…
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…

707 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

19 Experts available now in Live!

Get 1:1 Help Now