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

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

@H_404_9@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,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,320);
     Label2.Caption:=FloatToStr((Now-w_t1)/1000);
     w_dest.SavetoFile(ExtractFileDir(ParamStrUTF8(0))+'/3.bmp');
   /*   w_src,w_dest free ....*/
...
end;