Windows2000で追加された UpdateLayeredWindow と アルファマスクをもった
32BIT BITMAPを使用して、不定形、かつ、アルファマスク処理されたフォー
ムを作成します。
これで端がアルファ処理されて、ジャギーの目立たない不定形フォームがで
きます。2000専用ですけれども(^^;;

TMainForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private 宣言 }
    First : boolean;
  protected
    { Protected 宣言 }
    Surface : TBitmap;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WmDisplayChange(var Msg:TMsg); message WM_DISPLAYCHANGE;
    function  LoadBmp:boolean;
    function  MakeLayer:boolean;
end;

function UpdateLayeredWindow(_hwnd:HWND; dstHDC:HDC; pptDst:PPoint;
         ASize:PSize; srcHDC:HDC; pptSrc:PPoint; crKey:COLORREF;
         var bf : BLENDFUNCTION; dwFlag:DWORD):BOOL; stdcall;

implementation

const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY  = 1;
  LWA_ALPHA     = 2;
  ULW_COLORKEY  = 1;
  ULW_ALPHA     = 2;
  ULW_OPAQUE    = 4;
  AC_SRC_ALPHA  = 1;

function UpdateLayeredWindow;
  external 'user32.dll' name 'UpdateLayeredWindow';

procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do ExStyle := ExStyle or WS_EX_LAYERED;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  First:=true;
  Surface:=TBitmap.Create;
  Surface.PixelFormat:=pf32bit;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  Surface.free;
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  IF NOT First THEN Exit;
  First:=false;
  IF NOT LoadBmp THEN Close;
  IF NOT MakeLayer THEN Close;
end;

procedure TMainForm.WmDisplayChange(var Msg:TMsg);
begin
  IF NOT MakeLayer THEN Close;
end;

function  TMainForm.LoadBmp:boolean;
begin
  result:=false;
  try
    Surface.LoadFromFile('sample.bmp');
  except
    ON E:Exception DO BEGIN
      ShowMessage(E.Message);  Exit;
    END;
  end;
  IF Surface.PixelFormat<>pf32bit THEN BEGIN
    ShowMessage('not 32bit?'); Exit;
  END;
  result:=true;
end;

function TMainForm.MakeLayer:boolean;
var
  bf : TBlendFunction;
  zerop : TPoint;
  formsz : TSize;
begin
  result:=false;
  WITH bf DO BEGIN
    BlendOp:=AC_SRC_OVER;
    BlendFlags:=0;
    SourceConstantAlpha:=255; // 完全にALPHAをBITMAPに依存する場合
    AlphaFormat:=AC_SRC_ALPHA;
  END;
  zerop.x:=0; zerop.y:=0;
  formsz.cx:=width; formsz.cy:=height;
  IF NOT UpdateLayeredWindow(
        handle, 0,
        nil, // palleteを気にしないならnilでよろし
        @formsz, // フォームの大きさの指定 : 必須！
        Surface.canvas.handle, // サーフェイスを定義するDC
        @zerop, // サーフェイスを定義する画像の開始点
        0, bf, ULW_ALPHA) THEN BEGIN
    ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  END;
  result:=true;
end;

形の元となるビットマップは、以下のことに気をつけてください。
R=255, G=127, B=63 の点を ALPHA=100(0なら透明、255なら不透明)
で抜きたいときは、32BIT BITMAPのその点のデータを
　R = 255 * 100 div 255 = 100
  G = 127 * 100 div 255 =  49
  B =  63 * 100 div 255 =  24
  Alpha = 100
にしてください。単純にR=255,G=127,B=63,ALPHA=100としても予期
した形で描画されません(しばらく私はこれで嵌ってました)。

  　　　　　　　　　　　　　　　　　　　　市丸　剛(HGD00106)


 


- FDELPHI  MES(16):玉石混淆みんなで作るSample蔵【見本蓄積】 00/12/31 -

Original document by 市丸　剛　　　　氏 ID:(HGD00106)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。