Delphi - 位图边缘的渐变淡化

Question

任何以渐变方式淡化位图边缘的库/代码？

这样的事情：

编辑：最终代码

在您的示例之后，我们想出了这段代码，在使用scanlines进行优化后，它的速度提高了约10倍。理想情况下，我认为我应该将其转换为使用32位位图而不是修改实际的alpha图层，但现在这样做，ty！

procedure FadeEdges(b: TBitmap; Depth, Start, Col: TColor);
Var f, x, y, i: Integer;
    w,h: Integer;
    pArrays: Array of pRGBArray;
    xAlpha: Array of byte;
    sR, sG, sB: Byte;
    a,a2: Double;
    r1,g1,b1: Double;
    Lx,Lx2: Integer;
procedure AlphaBlendPixel(X, Y: Integer);
begin
  pArrays[y,x].rgbtRed   := Round(r1 + pArrays[y,x].rgbtRed   * a2);
  pArrays[y,x].rgbtGreen := Round(g1 + pArrays[y,x].rgbtGreen * a2);
  pArrays[y,x].rgbtBlue  := Round(b1 + pArrays[y,x].rgbtBlue  * a2);
end;
procedure AlphaBlendRow(Row: Integer; Alpha: Byte);
Var bR, bG, bB, xA: Byte;
    t: Integer;
    s,s2: Double;
begin
  s  := alpha / 255;
  s2 := (255 - Alpha) / 255;

  for t := 0 to b.Width-1 do begin
    bR := pArrays[Row,t].rgbtRed;
    bG := pArrays[Row,t].rgbtGreen;
    bB := pArrays[Row,t].rgbtBlue;
    pArrays[Row,t].rgbtRed   := Round(sR*s + bR*s2);
    pArrays[Row,t].rgbtGreen := Round(sG*s + bG*s2);
    pArrays[Row,t].rgbtBlue  := Round(sB*s + bB*s2);
  end;
end;
begin
  b.PixelFormat := pf24bit;

  // cache scanlines
  SetLength(pArrays,b.Height);
  for y := 0 to b.Height-1 do
   pArrays[y] := pRGBArray(b.ScanLine[y]);

  // pre-calc Alpha
  SetLength(xAlpha,Depth);
  for y := 0 to (Depth-1) do
   xAlpha[y] := Round(Start + (255 - Start)*y/(Depth-1));

  // pre-calc bg color
  sR := GetRValue(Col);
  sG := GetGValue(Col);
  sB := GetBValue(Col);

  // offsets
  w := b.Width-Depth;
  h := b.Height-Depth;

  for i := 0 to (Depth-1) do begin
    a  := xAlpha[i] / 255;
    a2 := (255 - xAlpha[i]) / 255;
    r1 := sR * a;
    g1 := sG * a;
    b1 := sB * a;
    Lx  := (Depth-1)-i;
    Lx2 := i+w;
    for y := 0 to b.Height - 1 do begin
      AlphaBlendPixel(Lx, y); // Left
      AlphaBlendPixel(Lx2, y); // right
    end;
  end;

  for i := 0 to (Depth-1) do begin
    AlphaBlendRow((Depth-1)-i, xAlpha[i]); // top
    AlphaBlendRow(i+(h), xAlpha[i]); // bottom
  end;

  SetLength(xAlpha,0);
  SetLength(pArrays,0);
end;

最终结果:(左=原始，右=在使用ListView悬停时混合）

编辑：进一步提高速度，是原始进程的两倍。

Answer 1

我可以给你一些我几年前写的代码来实现这个目标。它可能是一个有用的指南。代码是操作位图的类的一部分，这是将位图的左边缘淡化为白色背景的部分：

procedure TScreenShotEnhancer.FadeOutLeft(Position, Start: Integer);
var
  X, Y: Integer;
  F, N: Integer;
  I: Integer;
begin
  BeginUpdate;
  try
    N := Position;
    for I := 0 to N - 1 do begin
      X := Position - I - 1;
      F := Round(Start + (255 - Start)*I/N);
      for Y := 0 to Height - 1 do
        AlphaBlendPixel(X, Y, clWhite, F);
    end;
  finally
    EndUpdate;
  end;
end;

实际工作是用这种方法完成的：

procedure TScreenShotEnhancer.AlphaBlendPixel(X, Y: Integer; Color: TColor;
    Alpha: Byte);

var
  backgroundColor: TColor;
  displayColor: TColor;
  dR, dG, dB: Byte;
  bR, bG, bB: Byte;
  sR, sG, sB: Byte;
begin
  backgroundColor := Bitmap.Canvas.Pixels[X, Y];
  bR := GetRValue(backgroundColor);
  bG := GetGValue(backgroundColor);
  bB := GetBValue(backgroundColor);
  sR := GetRValue(Color);
  sG := GetGValue(Color);
  sB := GetBValue(Color);

  dR := Round(sR * alpha / 255 + bR * (255 - alpha) / 255);
  dG := Round(sG * alpha / 255 + bG * (255 - alpha) / 255);
  dB := Round(sB * alpha / 255 + bB * (255 - alpha) / 255);
  displayColor := RGB(dR, dG, dB);
  Bitmap.Canvas.Pixels[X, Y] := displayColor;
end;