When TCanvas.StretchDraw is not enough

Problem/Question/Abstract:

In some cases, the StretchDraw method of TCanvas can produce unsatisfying results. This article presents an alternative that can be better under some circumstances.

Answer:

One of the things I wanted the toolbar to do was to display the icons of the programs that it launches at a size smaller than that of ordinary icons. After retrieving the icon for a program and putting it in a bitmap.  I first tried to use TCanvas.StretchDraw to stretch the bitmap onto another bitmap which I would then assign to a TImage.  Although this worked, the icons came out looking bad.  It looked like StretchDraw droped pixels when it needed to make a bitmap smaller.  For large images this is probably a good idea but for my purpose, it wasn't adequate.  Instead I retrieved the color for each pixel in the source bitmap, calculated the fraction of each pixel in the destination bitmap that the source would cover and then assigned the final color of the pixel in the destination based on the proportions of pixels in the source that covered them.

unit ManipulateBitmaps;

interface

uses ShellAPI, Windows, SysUtils, Graphics, ExtCtrls;

procedure StretchBitmap(const Source, Destination: TBitmap);
{
This proceedure takes stretches the image in Source
and puts it in Destination.
The width and height of Destination must be specified before
calling StretchBitmap.
The PixelFormat of both Source and Destination are changed to pf32bit.
}

implementation

type
  PLongIntArray = ^TLongIntArray;
  TLongIntArray = array[0..16383] of longint;

procedure GetIndicies(const DestinationLength, SourceLength,
  DestinationIndex: integer;
  out FirstIndex, LastIndex: integer;
  out FirstFraction, LastFraction: double);
{
This proceedure compares the length of two pixel arrays and determines
which pixels in the destination are covered by those in the source.
It also determines what fraction of the first and last pixels are covered
in the destination.
}
var
  Index1A: double;
  Index2A: double;
  Index2B: integer;
begin
  Index1A := DestinationIndex / DestinationLength * SourceLength;
  FirstIndex := Trunc(Index1A);
  FirstFraction := 1 - Frac(Index1A);
  Index2A := (DestinationIndex + 1) / DestinationLength * SourceLength;
  Index2B := Trunc(Index2A);
  if Index2A = Index2B then
  begin
    LastIndex := Index2B - 1;
    LastFraction := 1;
  end
  else
  begin
    LastIndex := Index2B;
    LastFraction := Frac(Index2A);
  end;
  if FirstIndex = LastIndex then
  begin
    FirstFraction := FirstFraction - (1 - LastFraction);
    LastFraction := FirstFraction;
  end;
end;

procedure StretchBitmap(const Source, Destination: TBitmap);
{
This proceedure takes stretches the image in Source
and puts it in Destination.
The width and height of Destination must be specified
before calling StretchBitmap.
The PixelFormat of both Source and Destination are changed to pf32bit.
}
var
  P, P1, P2: PLongIntArray;
  X, Y: integer;
  FirstY, LastY, FirstX, LastX: integer;
  FirstYFrac, LastYFrac, FirstXFrac, LastXFrac: double;
  YFrac, XFrac: double;
  YIndex, XIndex: integer;
  AColor: TColor;
  Red, Green, Blue: integer;
  RedTotal, GreenTotal, BlueTotal, FracTotal: double;
begin
  Source.PixelFormat := pf32bit;
  Destination.PixelFormat := Source.PixelFormat;

  for Y := 0 to Destination.height - 1 do
  begin
    P := Destination.ScanLine[y];

    GetIndicies(Destination.Height, Source.Height, Y,
      FirstY, LastY, FirstYFrac, LastYFrac);

    for x := 0 to Destination.width - 1 do
    begin

      GetIndicies(Destination.width, Source.width, X,
        FirstX, LastX, FirstXFrac, LastXFrac);

      RedTotal := 0;
      GreenTotal := 0;
      BlueTotal := 0;
      FracTotal := 0;

      for YIndex := FirstY to LastY do
      begin
        P1 := Source.ScanLine[YIndex];
        if YIndex = FirstY then
        begin
          YFrac := FirstYFrac;
        end
        else if YIndex = LastY then
        begin
          YFrac := LastYFrac;
        end
        else
        begin
          YFrac := 1;
        end;

        for XIndex := FirstX to LastX do
        begin
          AColor := P1[XIndex];
          Red := AColor mod $100;
          AColor := AColor div $100;
          Green := AColor mod $100;
          AColor := AColor div $100;
          Blue := AColor mod $100;

          if XIndex = FirstX then
          begin
            XFrac := FirstXFrac;
          end
          else if XIndex = LastX then
          begin
            XFrac := LastXFrac;
          end
          else
          begin
            XFrac := 1;
          end;

          RedTotal := RedTotal + Red * XFrac * YFrac;
          GreenTotal := GreenTotal + Green * XFrac * YFrac;
          BlueTotal := BlueTotal + Blue * XFrac * YFrac;
          FracTotal := FracTotal + XFrac * YFrac;
        end;
      end;

      Red := Round(RedTotal / FracTotal);
      Green := Round(GreenTotal / FracTotal);
      Blue := Round(BlueTotal / FracTotal);

      AColor := Blue * $10000 + Green * $100 + Red;

      P[X] := AColor;
    end;
  end;
end;

end.


I recently wrote a freeware toolbar (http://www.mindspring.com/~rbwinston/launcher.htm)