unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Unit2, Buttons, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    SpeedButton1: TSpeedButton;
    Frame11: TFrame1;
    procedure FormActivate(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure Frame11Button1Click(Sender: TObject);
  strict private
    FDwmBorderIconsRect: TRect;
    FOldIconChangeHandler: TNotifyEvent;
    FSysIconImageList: TImageList;
    FUseCustomFrame: Boolean;
    FWndFrameSize: Integer;
    FOriginGlassFrameTop : Integer;
    function GetSysIconRect: TRect;
    procedure IconChanged(Sender: TObject);
    procedure InvalidateCustomTitleBar;
    procedure RecalcGlassFrameBounds(UpdateFrame: Boolean = True);
  protected
    procedure AdjustClientRect(var Rect: TRect); override; //
    procedure Paint; override;
    procedure PaintWindow(DC: HDC); override;
    procedure Resize; override;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP;
    procedure WMSetIcon(var Message: TWMSetIcon); message WM_SETICON;
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
      message WM_WINDOWPOSCHANGING;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
      message WM_WINDOWPOSCHANGED;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  Form1: TForm1;

implementation

uses CommCtrl, DwmApi, UxTheme, App.DwmUtils;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  AdjustClientRectメソッド
//  コントロールの子コントロールクライアント領域に配置される時に実行される
//  ここでは、TFormのGlassFrameの値で設定した内部をクライアント領域に再設定
//  TFrameのAlignをalClientにすると、この領域に収まるように描画される
//-----------------------------------------------------------------------------
procedure TForm1.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if FUseCustomFrame then begin
    Inc(Rect.Top,     GlassFrame.Top);
    Inc(Rect.Left,    GlassFrame.Left);
    Inc(Rect.Right,  -GlassFrame.Right);
    Inc(Rect.Bottom, -GlassFrame.Bottom);
  end;
end;

//-----------------------------------------------------------------------------
//  Cm_TextChangeメッセージ処理
//  コンポーネントのテキストあるいはキャプションが変更された時に、自分自身に送
//  ってくるメッセージの処理
//-----------------------------------------------------------------------------
procedure TForm1.CMTextChanged(var Message: TMessage);
begin
  inherited;
  InvalidateCustomTitleBar;
end;

//-----------------------------------------------------------------------------
//  フォームのアイコンの描画領域を取得
//-----------------------------------------------------------------------------
function TForm1.GetSysIconRect: TRect;
begin
  if not (biSystemMenu in BorderIcons) or
     not (BorderStyle in [bsSingle, bsSizeable]) then begin
    SetRectEmpty(Result);
  end else begin
    Result.Left   := 0;
    Result.Right  := GetSystemMetrics(SM_CXSMICON);
    Result.Bottom := GetSystemMetrics(SM_CYSMICON);

    if WindowState = wsMaximized then begin
      if CheckWin32Version(6, 0) then begin
        Result.Top := GlassFrame.Top - Result.Bottom - 2;
      end else begin
        Result.Top := GlassFrame.Top - Result.Bottom - 4;
      end;
    end else begin
      if CheckWin32Version(6, 0) then begin
        Result.Top := 6;
      end else begin
        Result.Top := 8;
     end;
   end;

    Inc(Result.Bottom, Result.Top);
  end;
end;

//-----------------------------------------------------------------------------
//  IconのOnChangedイベントハンドラ
//  現在のTImageListを破棄して元のIconのOnChangedイベントハンドラを実行
//-----------------------------------------------------------------------------
procedure TForm1.IconChanged(Sender: TObject);
begin
  FreeAndNil(FSysIconImageList);
  FOldIconChangeHandler(Sender);
end;

//-----------------------------------------------------------------------------
//  Paintメソッド処理
//  描画が必要になると実行されるメソッド
//
//  一度TImageListに格納して、TImageListに格納したアイコンを描画する
//  32ビットの画像としてTImageListに格納する、元の画像が32ビットでない場合でも
//  正確に描画できる
//-----------------------------------------------------------------------------
procedure TForm1.Paint;
var
  R : TRect;
begin
  if not FUseCustomFrame then begin
    inherited;
    exit;
  end;

  //アイコンの描画領域を取得してアイコンを描画
  R := GetSysIconRect;
  if not IsRectEmpty(R) then begin

    //TImageListを生成して、そこにアイコンの画像を格納
    if FSysIconImageList = nil then begin
      FSysIconImageList := Create32BitImageList(Self,
                                                GetSystemMetrics(SM_CXSMICON),
                                                GetSystemMetrics(SM_CYSMICON),
                                                1);
      AddFormIconToImageList(Self, FSysIconImageList);
    end;

    //格納した画像を描画
    R := GetSysIconRect;
    if WindowState = wsMaximized then begin
      R.Top := FWndFrameSize
    end;
    FSysIconImageList.Draw(Canvas, R.Left, R.Top, 0);
    R.Left := R.Right + FWndFrameSize - 3;
  end else begin
    R.Left := 0;
  end;

  //キャプションのテキストを描画
  R.Right  := FDwmBorderIconsRect.Left - FWndFrameSize - 1;
  R.Bottom := GlassFrame.Top;
  DrawGlassCaption(Self, R, True, taLeftJustify, tlTop);
  SelectClipRgn(Canvas.Handle, 0);

  inherited;
end;

//-----------------------------------------------------------------------------
//  PaintWindowメソッド処理
//  カスタムコントロールが WM_PAINT メッセージを受け取ると自動的に実行される
//  クライアント領域をクリップする
//-----------------------------------------------------------------------------
procedure TForm1.PaintWindow(DC: HDC);
var
  R : TRect;
begin
  if FUseCustomFrame then begin
    R := GetClientRect;
    with GlassFrame do begin
      ExcludeClipRect(DC, Left, Top, R.Right - Right, R.Bottom - Bottom);
    end;
  end;

  inherited;
end;

//-----------------------------------------------------------------------------
//  フォーム生成時とウィンドウの位置が変更になった時に実行
//  -R.Topはデフォルトでは30(タイトルバーの高さ)
//-----------------------------------------------------------------------------
procedure TForm1.RecalcGlassFrameBounds(UpdateFrame: Boolean = True);
var
  R : TRect;
begin
  SetRectEmpty(R);
  AdjustWindowRectEx(R,
                     GetWindowLong(Handle, GWL_STYLE),
                     False,
                     GetWindowLong(Handle, GWL_EXSTYLE));
  FWndFrameSize := R.Right;

  if FUseCustomFrame then begin
    GlassFrame.Top := FOriginGlassFrameTop - R.Top;
  end else begin
    GlassFrame.Top := 0;
  end;

  if UpdateFrame then
    SetWindowPos(Handle, 0, Left, Top, Width, Height, SWP_FRAMECHANGED);
end;

//-----------------------------------------------------------------------------
//  Resizeメソッド
//  リサイズの際に実行される
//  システムのアイコン(閉じるや最小化等)ボタンの左端の座標値を取得
//  キャプションの描画位置の設定に使用する
//-----------------------------------------------------------------------------
procedure TForm1.Resize;
begin
  if FUseCustomFrame then FDwmBorderIconsRect := GetDwmBorderIconsRect(Self);
  inherited;
end;

//-----------------------------------------------------------------------------
//  WM_ACTIVATEメッセージ処理
//  アクティブになったらタイトルバーを再描画
//-----------------------------------------------------------------------------
procedure TForm1.WMActivate(var Message: TWMActivate);
begin
  inherited;
  InvalidateCustomTitleBar;
end;

//-----------------------------------------------------------------------------
//  WM_NCCALCSIZEメッセージ処理
//  非クライアント領域のサイズ変更があった時に、クライアント領域を再計算
//  GlassFrameの上下左右の値の変更時に発生する
//  FWndFrameSizeのデフォルト値は8
//-----------------------------------------------------------------------------
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
  if not FUseCustomFrame then begin
    inherited;
  end else begin
    with Message.CalcSize_Params.rgrc[0] do begin
      Inc(Left,   FWndFrameSize);
      Dec(Right,  FWndFrameSize);
      Dec(Bottom, FWndFrameSize);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_NCHITTESTメッセージ処理
//  マウスの移動によって発生するメッセージ
//  タイトルバーは描画だけなので、そのままではマウスイベント等を受け付けない
//  このメッセージ内でマウス位置を検出して、その位置によって必要な結果を返す
//-----------------------------------------------------------------------------
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
  ClientPos : TPoint;
  IconRect  : TRect;
begin
  inherited;

  if not FUseCustomFrame then Exit;
  if not GlassFrame.Enabled then Exit;
  case Message.Result of
    HTCLIENT: ;
    HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
    begin
      Message.Result := HTCAPTION;
      Exit;
    end;
  else exit;
  end;

  ClientPos := ScreenToClient(Point(Message.XPos, Message.YPos));
  if ClientPos.Y > GlassFrame.Top then Exit;

  //ID: 27688 のコードは、このControlAtPosがない
  //これがないと、TGraphicControlのクリックイベントが検出できない
  if ControlAtPos(ClientPos, True) <> nil then Exit;

  IconRect := GetSysIconRect;
  if (ClientPos.X < IconRect.Right) and ((WindowState = wsMaximized) or
     ((ClientPos.Y >= IconRect.Top) and (ClientPos.Y < IconRect.Bottom)))
     then begin
    Message.Result := HTSYSMENU
  end else
  if ClientPos.Y < FWndFrameSize then begin
    Message.Result := HTTOP;
  end else begin
    Message.Result := HTCAPTION;
  end;
end;

//-----------------------------------------------------------------------------
//  WM_NCRBUTTONUPメッセージ処理
//  メニューやアイコンでマウス右ボタンをUP下時の処理
//-----------------------------------------------------------------------------
procedure TForm1.WMNCRButtonUp(var Message: TWMNCRButtonUp);
begin
  if not FUseCustomFrame or not (biSystemMenu in BorderIcons) then
    inherited
  else
    case Message.HitTest of
      HTCAPTION, HTSYSMENU: ShowSystemMenu(Self, Message);
    else inherited;
    end;
end;

//-----------------------------------------------------------------------------
//  WM_SETICONメッセージ処理
//-----------------------------------------------------------------------------
procedure TForm1.WMSetIcon(var Message: TWMSetIcon);
begin
  inherited;
  InvalidateCustomTitleBar;
end;

//-----------------------------------------------------------------------------
//  WM_WINDOWPOSCHANGINGメッセージ処理
//  ウィンドウの位置が変更されようとしている時の処理
//  ガラスフレームのサイズを再計算
//-----------------------------------------------------------------------------
procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
  SWP_STATECHANGED = $8000;
begin
  if FUseCustomFrame then begin
    if (Message.WindowPos.flags and SWP_STATECHANGED) = SWP_STATECHANGED then begin
      Invalidate;
    end;
  end else begin
    InvalidateCustomTitleBar;
  end;

  inherited;

  if (Message.WindowPos.flags and SWP_FRAMECHANGED <> 0) and FUseCustomFrame and
     (Message.WindowPos.flags <> SWP_FRAMECHANGED) then
    RecalcGlassFrameBounds(False);
end;

//-----------------------------------------------------------------------------
//  WM_WINDOWPOSCHANGEDメッセージ処理
//  ウィンドウの位置が変更されたら行う処理
//  変更されようとしている時に再計算した値で再設定
//-----------------------------------------------------------------------------
procedure TForm1.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  inherited;
  if (Message.WindowPos.flags and SWP_FRAMECHANGED <> 0) and FUseCustomFrame then
    Realign;
end;

//-----------------------------------------------------------------------------
//  WndProc処理
//  まだDWMによる描画ができない状態の時は元のWndProcを実行
//-----------------------------------------------------------------------------
procedure TForm1.WndProc(var Message: TMessage);
begin
  if not FUseCustomFrame or not HandleAllocated or
     not DwmDefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam,
                          Message.Result) then inherited;
end;

//-----------------------------------------------------------------------------
//  タイトルバー領域の再描画
//  キャプション(タイトル)の文字列、アイコン、フォームのりサイズの時に実行
//-----------------------------------------------------------------------------
procedure TForm1.InvalidateCustomTitleBar;
var
  R : TRect;
begin
  if not HandleAllocated or not FUseCustomFrame then Exit;

  R.Left   := 0;
  R.Top    := 0;
  R.Right  := Width;
  R.Bottom := GlassFrame.Top;
  InvalidateRect(Handle, @R, False);
end;

//=============================================================================
//  このフォームのOnCreateイベント
//=============================================================================
constructor TForm1.Create(AOwner: TComponent);
begin
  inherited;

  //フレームのアライメントの設定
  Frame11.Align := alClient;

  FOriginGlassFrameTop := GlassFrame.Top;
  //アプリ終了時にメモリリークの報告をする
  ReportMemoryLeaksOnShutdown := True;
  //コントロールのダブルバッファの設定
  EnableAppropriateDoubleBuffering(Self);

  //DWM(Desktop Window Manager)が有効どうかを調査
  //有効ならばウィンドウのGlassFrameのサイズ設定をする
  FUseCustomFrame := DwmCompositionEnabled and Self.GlassFrame.Enabled;
  if FUseCustomFrame then begin
    RecalcGlassFrameBounds;
  end;

  //表示するTFrame側に何か初期化の時に実行することがあれば実行
  //Frame11.Initialize(FUseCustomFrame);

  //アイコンが変更になった場合を考えて、IconのOnChangedイベントを定義
  FOldIconChangeHandler := Icon.OnChange;
  Icon.OnChange := IconChanged;
end;


//-----------------------------------------------------------------------------
//  この上は汎用的で、ブラックボックス的に使用できる
//  (OnCreateイベントは、コントロールの初期化等に使用する場合あり)
//  この下のコードは、このフォーム専用のコード
//-----------------------------------------------------------------------------


{ TForm1 }

//=============================================================================
//  このフォームのOnActivateイベント
//=============================================================================
procedure TForm1.FormActivate(Sender: TObject);
begin
  OnActivate := nil;
  if not DwmCompositionEnabled then
    MessageDlg('システムの Aero ( エアロ ) が無効になっています。',
               mtWarning, [mbOK], 0)
  else if FormsHaveCompatibilityCoords then
    MessageDlg('PE ヘッダの値を 6.0 ( Vista ) 以上にしてください',
               mtWarning, [mbOK], 0)
end;

//=============================================================================
//  フレームのButton1のOnClickイベント
//=============================================================================
procedure TForm1.Frame11Button1Click(Sender: TObject);
begin
  Application.MessageBox('フレームのボタンクリック', '情報');
end;

//=============================================================================
//  追加ボタンのOnClickイベント
//=============================================================================
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  Application.MessageBox('追加ボタンクリック', '情報');
end;

end.

unit Unit2;

interface

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

type
  TFrame1 = class(TFrame)
    Button1: TButton;
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    procedure Initialize(SupportsCustomFrame: Boolean);
  end;

implementation

{$R *.dfm}

//=============================================================================
//  表示する時に何か初期化実行することがあれば実行
//  このメソッドは、このフレームを配置したフォーム側から実行する
//=============================================================================
procedure TFrame1.Initialize(SupportsCustomFrame: Boolean);
begin
//
end;

end.

    if WindowState = wsMaximized then begin
      SpeedButton1.Top := FWndFrameSize - 3;
    end else begin
      SpeedButton1.Top := -1;
    end;

procedure TForm1.Button1Click(Sender: TObject);
var
  dwAttribute : Cardinal;
  pvAttribute : Cardinal;
begin
  dwAttribute := DWMWA_NCRENDERING_POLICY;
  pvAttribute := DWMNCRP_DISABLED;
  DwmSetWindowAttribute(Handle, dwAttribute, @pvAttribute, SizeOf(pvAttribute));
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  dwAttribute : Cardinal;
  pvAttribute : Cardinal;
begin
  dwAttribute := DWMWA_NCRENDERING_POLICY;
  pvAttribute := DWMNCRP_ENABLED;
  DwmSetWindowAttribute(Handle, dwAttribute, @pvAttribute, SizeOf(pvAttribute));
end;