32-Bit bitmap stretch with VCL TBitmap wrapper

Getting around VCL limitations

One would think bitmaps stretching is easy with VCL in Delphi? Well... it is... almost. when it does not involve 32 bit bitmaps (those bitmaps with per-pixel alpha channel). I've spent a few hours looking for a routine for speedy resizing of such bitmaps (but a routine that woudl not loos the alpha channel. Maybe it can be done somehow with WinAPI, but I have not managed to find a way. Besides - it would most probably not woth on DOS derived Windows (Win 9x). So after wasting those hours, i've wasted... a quarter more and written my own routine. It may not be fastest, it may not be the most efficient way, but it's clean and does its work.

Source code available here

Feel free to use it in your app for free or commercial use.

The Code

unit Stretch32BitBitmap;

interface

uses Math, Graphics, ImageProcessing;

procedure Stretch32(NewWidth, NewHeight: Cardinal; 
  Source, Target: TBitmap);

implementation

const
	MaxPixelCount = 32768;

type
  pRGBQarray = ^TRGBQuadarray;
  TRGBQuadArray = array[0..MaxPixelCount-1] of TRGBQuad;


procedure Stretch32(NewWidth, NewHeight: Cardinal; 
  Source, Target: TBitmap);
var
  xs, xd,yd, OldWidth, OldHeight: Integer;
  ssl, dsl: pRGBQarray;
begin

  if not(Source.Pixelformat = pf32Bit) then
  	Source.Pixelformat := pf32Bit;
  if not(Target.Pixelformat = pf32Bit) then
  	Target.Pixelformat := pf32Bit;

  OldWidth := Source.Width;
  OldHeight := Source.Height;
  Target.Width := NewWidth;
  Target.Height := NewHeight;

  for yd := 0 to NewHeight-1 do
    begin
      dsl:= Target.ScanLine[yd];
      ssl:= Source.ScanLine[Min(OldHeight - 1,
                                Trunc(yd * OldHeight / NewHeight))];
      for xd := 0 to NewWidth-1 do
        begin
          xs := Min(OldWidth-1,Trunc(xd * OldWidth / NewWidth));
          dsl[xd].rgbRed      := ssl[xs].rgbRed;
          dsl[xd].rgbGreen    := ssl[xs].rgbGreen;
          dsl[xd].rgbBlue     := ssl[xs].rgbBlue;
          dsl[xd].rgbReserved := ssl[xs].rgbReserved
        end;
    end;
end;


end.