delphi - WS_EX_LAYERED フォームにコントロールを描画するにはどうすればよいですか?

Question

このコードを使用して、単色の透明なフォームを描画します。

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  BlendFunction: TBlendFunction;
  BitmapPos: TPoint;
  BitmapSize: TSize;
  exStyle: DWORD;
  Bitmap: TBitmap;
begin
  exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
  if (exStyle and WS_EX_LAYERED = 0) then
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);

  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;
    Bitmap.SetSize(Width, Height);
    Bitmap.Canvas.Brush.Color:=clRed;
    Bitmap.Canvas.FillRect(Rect(0,0, Bitmap.Width, Bitmap.Height));
    BitmapPos := Point(0, 0);
    BitmapSize.cx := Bitmap.Width;
    BitmapSize.cy := Bitmap.Height;
    BlendFunction.BlendOp := AC_SRC_OVER;
    BlendFunction.BlendFlags := 0;
    BlendFunction.SourceConstantAlpha := 150;
    BlendFunction.AlphaFormat := 0;

    UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, Bitmap.Canvas.Handle,
      @BitmapPos, 0, @BlendFunction, ULW_ALPHA);

    Show;
  finally
    Bitmap.Free;
  end;
end;

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
  Message.Result := HTCAPTION;
end;

end. 

しかし、どのコントロールもフォームに表示されません。すでにこの質問UpdateLayeredWindow を通常のキャンバス/テキストアウトで読みましたが、SetLayeredWindowAttributes(受け入れられた回答が示唆するように) LWA_COLORKEY または LWA_ALPHA を使用しても機能しません。

UpdateLayeredWindow関数を使用するレイヤー形式でコントロール (TButton、TEdit) を描画することは可能ですか?

Answer 1

質問へのコメントで参照したドキュメントは少しあいまいです。以下のUsing Layered Windows (msdn)からの引用は、VCL が提供する組み込みのペイント フレームワークを使用するUpdateLayeredWindows場合は使用できないという点で、より明確です。つまり、ビットマップに描画したものだけが表示されます。

UpdateLayeredWindowを使用するには、レイヤード ウィンドウのビジュアル ビットを互換性のあるビットマップにレンダリングする必要があります。次に、互換性のある GDI デバイス コンテキストを介して 、必要なカラー キーおよびアルファ ブレンド情報と共に、ビットマップがUpdateLayeredWindow API に提供されます。ビットマップには、ピクセルごとのアルファ情報を含めることもできます。

UpdateLayeredWindowを使用する場合、アプリケーションは WM_PAINT またはその他の描画メッセージに応答する必要がないことに注意してください。これは、ウィンドウの視覚的表現が既に提供されており、システムがその画像の保存、構成、レンダリングを処理するためです。画面。 UpdateLayeredWindowは非常に強力ですが、多くの場合、既存の Win32 アプリケーションの描画方法を変更する必要があります。

次のコードは、視覚効果を適用する前に、フォームのメソッドを使用して VCL でビットマップをプリレンダリングする方法を示す試みですPaintTo((このメソッドの使用を推奨しているわけではありません。それが何にかかるかを示そうとしています..）また、「無地の半透明のフォームを作成する」だけの場合は、質問へのコメントにあるTLamaの提案が方法です。行く。

WM_PRINTCLIENTコードをライブフォームに入れました。ただし、視覚的な表示を必要とするすべてのアクションが「WM_PRINTCLIENT」をトリガーするわけではないため、これは少し無意味です。例えば以下のプロジェクトでは、ボタンやチェックボックスのクリックはフォームの外観に反映されますが、メモへの書き込みは反映されません。

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    CheckBox1: TCheckBox;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  protected
    procedure WMPrintClient(var Msg: TWMPrintClient); message WM_PRINTCLIENT;
  private
    FBitmap: TBitmap;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

const
  Alpha = $D0;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FBitmap := TBitmap.Create;
  FBitmap.PixelFormat := pf32bit;
  FBitmap.SetSize(Width, Height);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FBitmap.Free;
end;


procedure TForm1.WMPrintClient(var Msg: TWMPrintClient);
var
  exStyle: DWORD;
  ClientOrg: TPoint;
  X, Y: Integer;
  Pixel: PRGBQuad;
  BlendFunction: TBlendFunction;
  BitmapPos: TPoint;
  BitmapSize: TSize;
begin
  exStyle := GetWindowLongA(Handle, GWL_EXSTYLE);
  if (exStyle and WS_EX_LAYERED = 0) then
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);

  // for non-client araea only
  FBitmap.Canvas.Brush.Color := clBtnShadow;
  FBitmap.Canvas.FillRect(Rect(0,0, FBitmap.Width, FBitmap.Height));

  // paste the client image
  ClientOrg.X := ClientOrigin.X - Left;
  ClientOrg.Y := ClientOrigin.Y - Top;
  FBitmap.Canvas.Lock;
  PaintTo(FBitmap.Canvas.Handle, ClientOrg.X, ClientOrg.Y);
  FBitmap.Canvas.Unlock;

  // set alpha and have pre-multiplied color values
  for Y := 0 to (FBitmap.Height - 1) do begin
    Pixel := FBitmap.ScanLine[Y];
    for X := 0 to (FBitmap.Width - 1) do begin
      Pixel.rgbRed := MulDiv($FF, Alpha, $FF);    // red tint
      Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Alpha, $FF);
      Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Alpha, $FF);
      Pixel.rgbReserved := Alpha;
      Inc(Pixel);
    end;
  end;

  BlendFunction.BlendOp := AC_SRC_OVER;
  BlendFunction.BlendFlags := 0;
  BlendFunction.SourceConstantAlpha := 255;
  BlendFunction.AlphaFormat := AC_SRC_ALPHA;

  BitmapPos := Point(0, 0);
  BitmapSize.cx := Width;
  BitmapSize.cy := Height;
  UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, FBitmap.Canvas.Handle,
      @BitmapPos, 0, @BlendFunction, ULW_ALPHA);
end;

上記のフォームは次のようになります。

Answer 2

フォーム オン フォームはいつでも作成できます。それは最も幸せな解決策ではありませんが、うまくいきます。この問題を解決する最善の方法は GDI+ または D2D を利用することだと思いますが、残念ながらそれを理解できなかったため、「フォーム オン フォーム」アプローチを採用しました。

レイヤードフォーム:

unit uLayeredForm;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, System.Types,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.PngImage;

type
  TfrmLayered = class(TForm)
    procedure FormActivate(Sender: TObject);
  private
    FParentForm: TForm;
    procedure SetAlphaBackground(const AResourceName: String);
  public
    constructor Create(AOwner: TComponent; const ABitmapResourceName: String); reintroduce;
    procedure UpdatePosition;
  end;

var
  frmLayered: TfrmLayered;

implementation

{$R *.dfm}


constructor TfrmLayered.Create(AOwner: TComponent; const ABitmapResourceName: String);
begin
  inherited Create(AOwner);

  FParentForm := AOwner as TForm;
  SetAlphaBackground(ABitmapResourceName);
end;

procedure TfrmLayered.FormActivate(Sender: TObject);
begin
  if (Active) and (FParentForm.Visible) and (Assigned(FParentForm)) then
    FParentForm.SetFocus;
end;

procedure TfrmLayered.UpdatePosition;
begin
  if Assigned(FParentForm) then
  begin
    Left := FParentForm.Left - (ClientWidth - FParentForm.ClientWidth) div 2 - 1;
    Top := FParentForm.Top - (ClientHeight - FParentForm.ClientHeight) div 2 - 1;
  end;
end;

procedure TfrmLayered.SetAlphaBackground(const AResourceName: String);
var
  blend_func: TBlendFunction;
  imgpos    : TPoint;
  imgsize   : TSize;
  exStyle   : DWORD;
  png       : TPngImage;
  bmp       : TBitmap;
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 := TPngImage.Create;
  try
    png.LoadFromResourceName(HInstance, AResourceName);

    bmp := TBitmap.Create;
    try
      bmp.Assign(png);

      // resize the form
      ClientWidth := bmp.Width;
      ClientHeight := bmp.Height;

      // position image on form
      imgpos := Point(0, 0);
      imgsize.cx := bmp.Width;
      imgsize.cy := bmp.Height;

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

      UpdateLayeredWindow(Handle, 0, nil, @imgsize, bmp.Canvas.Handle, @imgpos, 0, @blend_func, ULW_ALPHA);
    finally
      bmp.Free;
    end;
  finally
    png.Free;
  end;
end;

end.

メインフォーム:

unit uMainForm;

interface

uses
  uLayeredForm, 
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;

type
  TfrmMain = class(TForm)
    imgClose: TImage;
    procedure FormCreate(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure imgCloseClick(Sender: TObject);
  private
    FLayeredForm: TfrmLayered;
  protected
    procedure WMMove(var AMessage: TMessage); message WM_MOVE;
  public
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

uses
  uCommon, Vcl.Themes, Vcl.Styles.FormStyleHooks;



procedure TfrmMain.FormCreate(Sender: TObject);
begin
  {$IFDEF DEBUG} ReportMemoryLeaksOnShutdown := TRUE; {$ENDIF}

  FLayeredForm := TfrmLayered.Create(self, 'MainBackground');
  FLayeredForm.Visible := TRUE;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FLayeredForm.Free;
end;

procedure TfrmMain.FormHide(Sender: TObject);
begin
  FLayeredForm.Hide;
end;

procedure TfrmMain.WMMove(var AMessage: TMessage);
begin
  if Assigned(FLayeredForm) then
    FLayeredForm.UpdatePosition;

  inherited;
end;

procedure TfrmMain.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  FormMove(self, Button, Shift, X, Y);
end;

procedure TfrmMain.FormShow(Sender: TObject);
begin
  if Assigned(FLayeredForm) then
  begin
    FLayeredForm.Show;
    FLayeredForm.UpdatePosition;
  end;
end;

procedure TfrmMain.imgCloseClick(Sender: TObject);
begin
  Close;
end;

initialization
  TStyleManager.Engine.RegisterStyleHook(TfrmMain, TFormStyleHookBackground);
  TFormStyleHookBackground.BackGroundSettings.Color := clBlack;
  TFormStyleHookBackground.BackGroundSettings.Enabled := TRUE;

end.

ご覧のとおり、2 つのフォームを 1 つのフォームとして動作させるには少し手作業が必要ですが、このコードで作業を開始できます。

滑らかな丸い境界線を持つフォームが必要だったので、次のスクリーンショットが最終結果として得られたものです。特にこの投稿では、上部のフォームとレイヤードの黒いフォームを簡単に区別できるように、上部のフォームをグレーで色付けしました。

エイリアス化された灰色のフォーム境界 ( SetWindowRgn()および CreateRoundRectRgn() API によって作成) とアンチエイリアス化された黒色のフォーム境界の違いがはっきりとわかります。