[lazarus] 分享一个BMP图像平滑缩放的代码

刚把fastbmp的SmoothResize移植成功，速度比lazarus官方例子要快接近一倍，效果也比他的好，常规的缩放，有些点阵会有变色，但通过插值缩放则不会，而且细节还会得到保留。

先贴出lazarus官方的source:

procedure StretchDrawBitmapToBitmap(SourceBitmap, DestBitmap: TBitmap; DestWidth, DestHeight: integer);
var
  DestIntfImage, SourceIntfImage: TLazIntfImage;
  DestCanvas: TLazCanvas;
begin
  // Prepare the destination
  DestBitmap.Height:=DestHeight;
  DestBitmap.Width:=DestWidth;
  DestIntfImage := TLazIntfImage.Create(0, 0);
  DestIntfImage.LoadFromBitmap(DestBitmap.Handle, 0);


  DestCanvas := TLazCanvas.Create(DestIntfImage);


  //Prepare the source
  SourceIntfImage := TLazIntfImage.Create(0, 0);
  SourceIntfImage.LoadFromBitmap(SourceBitmap.Handle, 0);


  // Execute the stretch draw via TFPSharpInterpolation
  DestCanvas.Interpolation := TFPSharpInterpolation.Create;
  DestCanvas.StretchDraw(0, 0, DestWidth, DestHeight, SourceIntfImage);


  // Reload the image into the TBitmap
  DestBitmap.LoadFromIntfImage(DestIntfImage);


  SourceIntfImage.Free;
  DestCanvas.Interpolation.Free;
  DestCanvas.Free;
  DestIntfImage.Free;
end;

SmoothResize的source ，代码源自若干年前Gordon Alex Cowie等大神之手的fastbmp，原代码要依赖window api，故一直编译不成功，所以只能抽离此procedure。原来的流程是首选获得bitmap的点阵数据储存于内存，然后scanline时直接取内存块对应位置的数据，速度相当迅猛。当年楼主作的一个类似remote control之类的工具就使用了fastbmp，比用tbitmap快多了而且不耗内存。现在谷歌fastbmp，资料已经寥寥无几了，感叹delphi/pascal已到了末日黄花。。。。

type
TFColor = record
    b, g, r: Byte;
  end;
  PFColor = ^TFColor;


  TLine = array[0..0] of TFColor;
  PLine = ^TLine;
procedure SmoothResize(Src,Dst: TBitmap;newWidth,newHeight:integer);
var
  x, y, xP, yP,
    yP2, xP2: Integer;
  Read, Read2: PLine;
  t, z, iz, z2, iz2: Integer;
  pc: PFColor;
begin
  if src.Width = 1 then
  begin
    Exit;
  end;
  Dst.Width:=newWidth;
  Dst.Height:=newHeight;
  {if (Dst.Width = src.Width) and (Dst.Height = src.Height) then
  begin
    CopyMemory(Dst.Bits, Bits, Size);
    Exit;
  end;
  }
  xP2 := ((src.Width - 1) shl 16) div Dst.Width;
  yP2 := ((src.Height - 1) shl 16) div Dst.Height;
  yP := 0;
  for y := 0 to Dst.Height - 1 do
  begin
    xP := 0;
    Read := src.ScanLine[yP shr 16];
    if yP shr 16 < src.Height - 1 then
      Read2 := src.ScanLine[yP shr 16 + 1]
    else
      Read2 := src.ScanLine[yP shr 16];
    pc := Dst.ScanLine[y];
    z2 := yP and $FFFF;
    iz2 := $10000 - z2;
    for x := 0 to Dst.Width - 1 do
    begin
      t := xP shr 16;
      z := xP and $FFFF;
      iz := $10000 - z;
      pc^.b :=
        (((Read^[t].b * iz + Read^[t + 1].b * z) shr 16) * iz2 +
        ((Read2^[t].b * iz + Read2^[t + 1].b * z) shr 16) * z2) shr 16;
      pc^.r :=
        (((Read^[t].r * iz + Read^[t + 1].r * z) shr 16) * iz2 +
        ((Read2^[t].r * iz + Read2^[t + 1].r * z) shr 16) * z2) shr 16;
      pc^.g :=
        (((Read^[t].g * iz + Read^[t + 1].g * z) shr 16) * iz2 +
        ((Read2^[t].g * iz + Read2^[t + 1].g * z) shr 16) * z2) shr 16;
      Inc(pc);
      Inc(xP, xP2);
    end;
    Inc(yP, yP2);
  end;
end;

调用例子如下，在exe同目录，必须存在1.bmp图片，运行后会生成2.bmp/3.bmp，很明显2.bmp要平滑得多，而且不变色。

procedure TForm1.Button1Click(Sender: TObject);
var w_src_path:string;
  w_src,w_dest:TBitmap;
  w_t1:TDateTime;
begin
     w_src_path:=ExtractFileDir(ParamStrUTF8(0))+'/1.bmp';
     w_src:=TBitmap.Create;
     w_src.LoadFromFile(w_src_path);
     w_dest:=TBitmap.Create;
     w_t1:=Now;
     SmoothResize(w_src,w_dest,320,320);
     Label1.Caption:=FloatToStr((Now-w_t1)/1000);
     w_dest.SaveToFile(ExtractFileDir(ParamStrUTF8(0))+'/2.bmp');
     w_t1:=Now;
     StretchDrawBitmapToBitmap(w_src,w_dest,320,320);
     Label2.Caption:=FloatToStr((Now-w_t1)/1000);
     w_dest.SaveToFile(ExtractFileDir(ParamStrUTF8(0))+'/3.bmp');
   /*   w_src,w_dest free ....*/
...
end;