在Delphi中淡入一个带有alpha通道的PNG表单

Question

几年前，Vista首次发布时，我曾提出过一个问题，但从未解决该问题，将其作为以后考虑的事情。我有一个启动画面，我非常努力地让它看起来很棒。它是一个32bpp alpha-blended PNG。我有一些代码（如果需要，我可以挖掘出来！）在Windows XP下或在打开桌面组合时，在Vista+下运行得非常好。然而，在Vista+下，所有透明部分都是黑色的，破坏了它看起来很棒的一切！因此，我的问题是：是否有人能够以一种方式显示32bpp alpha-blended PNG作为启动屏幕，使其在激活和未激活桌面组合时都能正常工作？如果需要，我不反对使用第三方组件，无论是免费还是收费。理想情况下，这将在Delphi 7中运行。更新：除了下面的答案非常好之外，我发现TMS TAdvSmoothSplashScreen组件也处理得非常好，尽管有些复杂。

- Tim Sullivan

Answer 1

Tim，我在选择“Windows Classic”主题的Vista/D2007上尝试了这个：

Delphi中的Alpha Blended启动画面-第二部分 http://melander.dk/articles/alphasplash2/2/

我没有看到黑色背景...它依然很棒。

- Bob S

---

+1. 我最近遵循了那篇文章（第一部分和第二部分），并确认它适用于Vista Aero。 - Mike Sutton

嗯，对我来说在 Aero 下似乎几乎可以工作。出于未知原因，窗口边框出现了。使用 Delphi 7 编译；其他人也会发生这种情况吗？ - Tim Sullivan

是的，即使启用了 Aero，它看起来也更好... :)你的驱动程序是否最新？ - Bob S

是的，它们尽可能地保持最新！要明确一下，这不是黑边框，而是像普通窗体一样，有最小化、最大化和关闭按钮，标题栏之类的。 - Tim Sullivan

根据下面的评论，将BorderStyle设置为bsNone解决了视觉问题！谢谢！ - Tim Sullivan

Answer 2

Bob S提供的文章给出了正确答案。由于该文章包含了一些您实际上需要的额外信息，因此在此我会通过它创建表单/单位（请注意，您将需要从此处获取GraphicEx库）：

unit Splash2Form;

interface

    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, ExtCtrls, GraphicEx;

type
    TSplash2 = class(TForm)
    private
        { Private declarations }
    procedure PreMultiplyBitmap(Bitmap: TBitmap);
    public
        constructor Create(Owner: TComponent);override;
        { Public declarations }
        procedure CreateParams(var Params: TCreateParams);override;
    procedure Execute;
  end;

var
  Splash2: TSplash2;

implementation

{$R *.dfm}

{ TSplash2 }

constructor TSplash2.Create(Owner: TComponent);
begin
  inherited;
  Brush.Style := bsClear;
end;

procedure TSplash2.CreateParams(var Params: TCreateParams);
begin
    inherited;
end;

procedure TSplash2.Execute;
var exStyle: DWORD;
    BitmapPos: TPoint;
  BitmapSize: TSize;
  BlendFunction: TBlendFunction;
  PNG: TPNGGraphic;
  Stream: TResourceStream;
begin
  // Enable window layering
  exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
  if (exStyle and WS_EX_LAYERED = 0) then
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);

  PNG := TPNGGraphic.Create;
  try

      Stream := TResourceStream.Create(HInstance, 'SPLASH', RT_RCDATA);
      try
          PNG.LoadFromStream(Stream);
    finally
        Stream.Free;
        end;

    PreMultiplyBitmap(PNG);

      ClientWidth := PNG.Width;
    ClientHeight := PNG.Height;

      BitmapPos := Point(0, 0);
    BitmapSize.cx := ClientWidth;
      BitmapSize.cy := ClientHeight;

      // Setup alpha blending parameters
    BlendFunction.BlendOp := AC_SRC_OVER;
      BlendFunction.BlendFlags := 0;
    BlendFunction.SourceConstantAlpha := 255;
      BlendFunction.AlphaFormat := AC_SRC_ALPHA;

    // ... and action!
      UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, PNG.Canvas.Handle,
      @BitmapPos, 0, @BlendFunction, ULW_ALPHA);

      Show;

  finally
    PNG.Free;
  end;
end;

procedure TSplash2.PreMultiplyBitmap(Bitmap: TBitmap);
var
  Row, Col: integer;
  p: PRGBQuad;
  PreMult: array[byte, byte] of byte;
begin
  // precalculate all possible values of a*b
  for Row := 0 to 255 do
    for Col := Row to 255 do
    begin
      PreMult[Row, Col] := Row*Col div 255;
      if (Row <> Col) then
        PreMult[Col, Row] := PreMult[Row, Col]; // a*b = b*a
    end;

  for Row := 0 to Bitmap.Height-1 do
  begin
    Col := Bitmap.Width;
    p := Bitmap.ScanLine[Row];
    while (Col > 0) do
    begin
      p.rgbBlue := PreMult[p.rgbReserved, p.rgbBlue];
      p.rgbGreen := PreMult[p.rgbReserved, p.rgbGreen];
      p.rgbRed := PreMult[p.rgbReserved, p.rgbRed];
      inc(p);
      dec(Col);
    end;
  end;
end;

end.

- Mike Sutton

---

我有与上述相同的问题：在Vista Aero中，它周围有窗口边框。编译于Delphi 7。你有什么想法？ - Tim Sullivan

你是否将 TSplash2.BorderStyle 设置为 bsNone？这样可以完全移除窗口边框。 - skamradt

尝试将边框样式更改为bsNone。如果这不起作用，等我晚些时候到工作机器上再看看。 - Mike Sutton

更改边框样式解决了问题！谢谢！ - Tim Sullivan