ホーム >プログラム >Delphi 6 ローテクTips

フォームのフェードイン・フェードアウト

プログラムの開始や終了のときにフォームがフェードインやフェードアウトするとちょっとかっこいいかなと思いました。
で、それがTFormのAlphaBlendプロパティとAlphaBlendValueプロパティを利用することで簡単にできてしまいます。

と、思ったらそんなことをするまでもなくAPI一発でもっと簡単に済んでしまうことが分かりました。
更にWindows 7(Vistaからなのかな?)では何もしなくてもプログラムの開始と終了の時にフェードインやフェードアウトするようになってました。

参考サイト

AnimateWindow API

フェードイン

procedure TForm1.FormCreate(Sender: TObject);
begin
  AnimateWindow(Handle, 200, AW_BLEND or AW_ACTIVATE);
end;

フェードアウト

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  AnimateWindow(Handle, 200, AW_BLEND or AW_HIDE);
end;

こんな便利なAPIがあったとは、、というくらいあっけなくスムーズにできてしまいます。
このAPIを知る前に書いたAlphaBlendValueを調整しながらループを回すやり方のようにWindowsMediaPlayerコンポーネントを非表示にしておく必要もありません。

注意点


以前のやり方

以下の記述はAnimateWindow APIを知る前に書いたものです。
AnimateWindow APIに比べて何のメリットもありません。
ただ、ループの処理を指定時間内に収めようと努力してる部分は後々参考になるであろうということで残してあるものです。

フェードイン

まず設計時にフォームのAlphaBlendプロパティをTrueに、AlphaBlendValueプロパティを0にセットしておきます。

そしてフォームのOnCreateイベントで徐々にAlphaBlendValueプロパティの値を増やしていきます。
それだけです。

procedure TForm1.FormCreate(Sender: TObject);
const
  lci_STEP = 50;
var
  i: Integer;
begin
  Show;
  for i := 0 to lci_STEP do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    Application.ProcessMessages;
  end;
  AlphaBlendValue := 255;
  AlphaBlend      := False;
end;

例ではフェードインのステップを50にしていますが、そのへんは適当に調整してください。
ループ中で時間を取得して各ステップごとに必要な時間まで待機させる方が丁寧で良いのかも知れません。

procedure TForm1.FormCreate(Sender: TObject);
const
  lci_STEP     = 50;
  lci_FADETIME = 1000; //フェードインにかける時間。
var
  i: Integer;
  li_Start: DWORD;
  li_Sleep: Integer;
begin
  Show;
  li_Start := GetTickCount;
  for i := 0 to lci_STEP do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    Application.ProcessMessages;
    li_Sleep := Trunc(li_Start + i * (lci_FADETIME / lci_STEP) - GetTickCount);
    if (li_Sleep > 0) then begin
      Sleep(li_Sleep);
    end;
  end;
  AlphaBlendValue := 255;
  AlphaBlend      := False;
end;

フェードアウト

フェードアウトするにはフォームのOnCloseイベントに処理を書きます。
OnDestroyイベントはNGです。

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
const
  lci_STEP = 50;
var
  i: Integer;
begin
  AlphaBlendValue := 255;
  AlphaBlend      := True;
  Application.ProcessMessages; //必須。ないと一瞬ブラックアウトする。
  for i := lci_STEP downto 0 do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    Application.ProcessMessages;
  end;
  AlphaBlendValue := 0;
  Hide;
end;

ループ終了後の2行は実は余計なのですが、一応念のため。

これも丁寧にやるには

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
const
  lci_STEP     = 50;
  lci_FADETIME = 1000; //フェードアウトにかける時間。
var
  i: Integer;
  li_Start: DWORD;
  li_Sleep: Integer;
begin
  AlphaBlendValue := 255;
  AlphaBlend      := True;
  Application.ProcessMessages; //必須。ないと一瞬ブラックアウトする。
  li_Start := GetTickCount;
  for i := lci_STEP downto 0 do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    Application.ProcessMessages;
    li_Sleep := Trunc(li_Start + (lci_STEP - i) * (lci_FADETIME / lci_STEP) - GetTickCount);
    if (li_Sleep > 0) then begin
      Sleep(li_Sleep);
    end;
  end;
  AlphaBlendValue := 0;
  Hide;
end;

などとします。
アンダーラインを引いた部分はフェードインの場合と違っています。
フェードアウトの場合ステップが50から小さくなっていくのでフェードインと同じ要領でやるとうまくきません。

注意点

TWindowsMediaPlayerやTMediaPlayerなどを利用してフォーム上で動画を再生させているときにそのフォームをフェードアウトさせるとフェードアウトした後にフォームの後ろにあった他のアプリケーションの一部に黒い痕跡が残ってしまうことがあります。
多分ビデオオーバーレイがらみだとは思うのですが、ビデオオーバーレイ用の色(RGBで 16, 0, 16)が残ってしまいます。

それを防ぐにはフェードアウトする前にTWindowsMediaPlayerやTMediaPlayerを非表示にします。

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
const
  lci_STEP     = 50;
  lci_FADETIME = 1000; //フェードアウトにかける時間。
var
  i: Integer;
  li_Start: DWORD;
  li_Sleep: Integer;
begin
  AlphaBlendValue := 255;
  AlphaBlend      := True;
  WindowsMediaPlayer1.Visible := False; //この位置がベスト
  Application.ProcessMessages;
  li_Start := GetTickCount;
  for i := lci_STEP downto 0 do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    Application.ProcessMessages;
    li_Sleep := Trunc(li_Start + (lci_STEP - i) * (lci_FADETIME / lci_STEP) - GetTickCount);
    if (li_Sleep > 0) then begin
      Sleep(li_Sleep);
    end;
  end;
  AlphaBlendValue := 0;
  Hide;
end;

あるいはフェードアウトの処理中にApplication.ProcessMessagesを呼ばないようにし、最後のHideを削除することでも防ぐことができるようです。
この場合一度ブラックアウトしてから徐々に色が薄れていくことになるので若干不自然さはあります。

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
const
  lci_STEP     = 50;
  lci_FADETIME = 1000; //フェードアウトにかける時間。
var
  i: Integer;
  li_Start: DWORD;
  li_Sleep: Integer;
begin
  AlphaBlendValue := 255;
  AlphaBlend      := True;
  //Application.ProcessMessages;
  li_Start := GetTickCount;
  for i := lci_STEP downto 0 do begin
    AlphaBlendValue := Trunc(i * (255 / lci_STEP));
    //Application.ProcessMessages;
    li_Sleep := Trunc(li_Start + (lci_STEP - i) * (lci_FADETIME / lci_STEP) - GetTickCount);
    if (li_Sleep > 0) then begin
      Sleep(li_Sleep);
    end;
  end;
  AlphaBlendValue := 0;
  //Hide;
end;

2010-02-10:AnimateWindow API一発でループを回す必要もなく済んでしまうことが判明。