Delphi Advent Calender 2018の8日の記事です。
Windows10ではこれまでのFlat デザインから Fluent Design に移行していくようです。
マイクロソフトの公式ページ(IEでは見ることができません)
https://www.microsoft.com/design/fluent/
UWPアプリ向けには以下のような記事が提供されています
https://docs.microsoft.com/ja-jp/windows/uwp/design/fluent-design-system/
見た目がかっこいいですね。そこでDelphiでもこの一部での実現できないかと考えました。
この記事ではアクリル効果に挑戦したいと思います。
UWPではXAMLで指定できるようです。XAML Controls GallaryのArcylicで確認できます。
https://docs.microsoft.com/ja-jp/windows/uwp/design/style/acrylic
.netのWinFormでもぷFluentDesignForm.EnableAcrylicAccentの指定で簡単に作れるようですね。
VCLで同様のコントロールを作るのは難しそうなので，まずはフォームをアクリルにして，TWinControlから派生していないImageでボタンを実装することを考えました。
まずはフォームをアクリルにする方法について検討します。
フォームをアクリルフォームにする
アクリルフォームを実現するためにuser32.dllにあるSetWindowCompositionAttributeを使ってみたいと思います。これはWindows10にしかないのでWindows10の時だけアクリルフォームになるようにします。さらにWindows 10 April 2018 Updateより利用できるようになったACCENT_ENABLE_ACRYLICBLURBEHINDを使いたいと思います。それからFormのGrassFrameを使います。ネット上の記事を参考に下のようなコードを書いてみました。
type
AccentPolicy = packed record
AccentState: Integer;
AccentFlags: Integer;
GradientColor: Integer;
AnimationId: Integer;
end;
WindowCompositionAttributeData = packed record
Attribute: THandle;
Data: Pointer;
SizeOfData: ULONG;
end;
var
SetWindowCompositionAttribute:function (hWnd: HWND; var data: WindowCompositionAttributeData):integer; stdcall;
function AcrylicFormSet(AForm:TForm;AColor:UInt32):integer;
const
WCA_ACCENT_POLICY = 19;
ACCENT_ENABLE_ACRYLICBLURBEHIND = 4; // Windows 10 April 2018 Update
DrawLeftBorder = $20;
DrawTopBorder = $40;
DrawRightBorder = $80;
DrawBottomBorder = $100;
var
dwm10: THandle;
data: WindowCompositionAttributeData;
accent: AccentPolicy;
begin
Result:=-1;// Not found Windows 10 SetWindowCompositionAttribute in user32.dll
AForm.GlassFrame.Bottom:=-1;
AForm.GlassFrame.Top:=-1;
AForm.GlassFrame.Left:=-1;
AForm.GlassFrame.Right:=-1;
AForm.GlassFrame.SheetOfGlass:=True;
AForm.GlassFrame.Enabled:=True;
AForm.BorderStyle := bsNone; //フォームのボーダーは無しにする
AForm.BorderIcons := [biSystemMenu, biMinimize]; // ボーダーアイコンは無し
AForm.DoubleBuffered:=True; // ダブルバッファにする
dwm10 := LoadLibrary('user32.dll');
try
@SetWindowCompositionAttribute := GetProcAddress(dwm10, 'SetWindowCompositionAttribute');
if @SetWindowCompositionAttribute <> nil then begin
accent.AccentState := ACCENT_ENABLE_ACRYLICBLURBEHIND;
accent.GradientColor := AColor;
accent.AccentFlags := DrawLeftBorder or DrawTopBorder or DrawRightBorder or DrawBottomBorder;
data.Attribute := WCA_ACCENT_POLICY;
data.SizeOfData := SizeOf(accent);
data.Data := @accent;
SetWindowCompositionAttribute(AForm.Handle, data);
Result:=0;
end;
finally
FreeLibrary(dwm10);
end;
end;
フォームのクリエイトイベントの先頭で
AcrylicFormSet(Self,$11880000);
等と書くと動作します。$11880000はアルファを含む色指定で，アクリルフォームの色を指定できます。しかし，フォームのボーダーにbsNoneを設定してあるため，動かしたりリサイズすることができません。これはフォームのボーダーをbsNone以外にすると，フォームの境界線がきれいに表示されなくなるためです。
bsNoneを指定されたフォームを動かしたりリサイズできるようにする
そこで，WM_NCHITTESTメッセージを使って，フォームを動かせるようにしたいと思います。
まず，WM_NCHITTESTを処理する関数**_WMNCHitTest**を書きます。
var
FAllowSize: Boolean=True; // リサイズする場合にはTrue
FAllowMove: Boolean=True; // 移動する場合にはTrue
procedure _WMNCHitTest(AForm:TForm;var Msg: TWMNCHitTest);
const
hCORNER: Integer=19;
hWIDTH : Integer= 3;
hHEIGHT: Integer=48;
var
ScreenPt : TPoint;
MoveArea : TRect;
begin
Msg.Result :=HTCLIENT;
if not (csDesigning in AForm.ComponentState) then begin
ScreenPt := AForm.ScreenToClient(Point(Msg.Xpos, Msg.Ypos));
if FAllowSize then begin
if (ScreenPt.x < hCORNER)and(ScreenPt.y < hCORNER) then begin // top left corner
Msg.Result := HTTOPLEFT
end else if (ScreenPt.x < hCORNER)and(ScreenPt.y >= AForm.Height-hCORNER) then begin // bottom left corner
Msg.Result := HTBOTTOMLEFT
end else if (ScreenPt.x >= AForm.Width-hCORNER)and(ScreenPt.y < hCORNER) then begin // top right corner
Msg.Result := HTTOPRIGHT
end else if (ScreenPt.x >= AForm.Width-hCORNER)and(ScreenPt.y >= AForm.Height-hCORNER) then begin // bottom right corner
Msg.Result := HTBOTTOMRIGHT
end else if (ScreenPt.x<hWIDTH) then begin // left side
Msg.Result := HTLEFT
end else if (ScreenPt.y<hWIDTH) then begin // top side
Msg.Result := HTTOP
end else if (ScreenPt.x>=AForm.Width -hWIDTH) then begin // right side
Msg.Result := HTRIGHT
end else if (ScreenPt.y>=AForm.Height-hWIDTH) then begin // bottom side
Msg.Result := HTBOTTOM
end;
end;
end;
if FAllowMove then begin // スクリーンをドラッグで動かしたい場合 上部hHEIGHTピクセルだけ
MoveArea := Rect(hWIDTH, hWIDTH, AForm.Width - hWIDTH, hHEIGHT - hWIDTH);
if PtInRect(MoveArea, ScreenPt) then begin
Msg.Result := HTCAPTION;
end;
end;
end;
そして，WM_NCHITTESTメッセージを処理するメソッドをフォームに宣言します。
type
TForm1 = class(TForm)
・・・
private
・・・
procedure WMNCHitTest(var Msg: TWMNCHitTest);message WM_NCHITTEST;
public
end;
そして，このメソッドの処理を記述します。
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
_WMNCHitTest(Self,Msg);
end;
これでフォームの上部hHEIGHTをドラッグすると移動したり，フォームの境界線付近の内側をドラッグするとリサイズできるようになりました。
リサイズはフォームの内側のドラッグなので，フォームの淵まで使ってWinControlを配置すると動作しなくなります。本当はフォームの外側をドラッグできるようにしたかったのですが，やり方がわかりませんでした。アドバイスをいただけるとありがたいです。
実装にあたっての注意 - オフする機能を実装すること！
アクリルフォームを実装する場合には，ノートパソコンやタブレットの省電力のためにオフにする機能を実装することが推奨されています。今回の実装だとアプリの再起動が必要な方法しか思いつきませんでしたが，アプリの再起動なしに実現できる方法をご存知の方がいらっしゃいましたら是非教えてください！
まとめ
VCLのGlassFrameとuser32.dllのSetWindowCompositionAttributeを使ってアクリルフォームを作りました。Windows10でしか動作しませんが，VCLでもここまでできることがわかりました。
また作成したフォームがbsNoneだったためフォームの移動とリサイズする機能を自前でのせる方法を追加し Fluent Design風なアプリケーションをVCLでもかけそうな気がしています。不完全なものではありますが，皆さんのお役に立てば幸いです。
参考文献
このコードを書くにあたって，以下の記事を参考にさせていただきました。
CODIGOBIT - Enable Windows 10 Aero Glass a.k.a Blur Behind in our Delphi project
http://vhanla.codigobit.info/2015/07/enable-windows-10-aero-glass-aka-blur.html
Slashback Software - Borderless window resizing with WM_NCHITTEST
https://slashbackassociates.com/blog/Borderless-window-resizing-with-WM-NCHITTEST
ACCENT_ENABLE_ACRYLICBLURBEHIND
https://stackoverflow.com/questions/32724187/how-do-you-set-the-glass-blend-colour-on-windows-10