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

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

先贴出lazarus官方的source:

procedure StretchDrawBitmapToBitmap(SourceBitmap, DestBitmap: TBitmap; DestWidth, DestHeight: integer);
varDestIntfImage, SourceIntfImage: TLazIntfImage;DestCanvas: TLazCanvas;
begin// Prepare the destinationDestBitmap.Height:=DestHeight;DestBitmap.Width:=DestWidth;DestIntfImage := TLazIntfImage.Create(0, 0);DestIntfImage.LoadFromBitmap(DestBitmap.Handle, 0);DestCanvas := TLazCanvas.Create(DestIntfImage);//Prepare the sourceSourceIntfImage := TLazIntfImage.Create(0, 0);SourceIntfImage.LoadFromBitmap(SourceBitmap.Handle, 0);// Execute the stretch draw via TFPSharpInterpolationDestCanvas.Interpolation := TFPSharpInterpolation.Create;DestCanvas.StretchDraw(0, 0, DestWidth, DestHeight, SourceIntfImage);// Reload the image into the TBitmapDestBitmap.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 = recordb, g, r: Byte;end;PFColor = ^TFColor;TLine = array[0..0] of TFColor;PLine = ^TLine;
procedure SmoothResize(Src,Dst: TBitmap;newWidth,newHeight:integer);
varx, y, xP, yP,yP2, xP2: Integer;Read, Read2: PLine;t, z, iz, z2, iz2: Integer;pc: PFColor;
beginif src.Width = 1 thenbeginExit;end;Dst.Width:=newWidth;Dst.Height:=newHeight;{if (Dst.Width = src.Width) and (Dst.Height = src.Height) thenbeginCopyMemory(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 dobeginxP := 0;Read := src.ScanLine[yP shr 16];if yP shr 16 < src.Height - 1 thenRead2 := src.ScanLine[yP shr 16 + 1]elseRead2 := src.ScanLine[yP shr 16];pc := Dst.ScanLine[y];z2 := yP and $FFFF;iz2 := $10000 - z2;for x := 0 to Dst.Width - 1 dobegint := 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;
beginw_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;