窗体皮肤实现

现在皮肤控件也很多，但每次装一堆控件，使用又繁琐。稍微研究一下内部机制，还是比较简单的。

主要会使用到下面几个消息

 1 const
    WM_NCUAHDRAWCAPTION = $00AE;
    WM_NCUAHDRAWFRAME = $00AF;

// 绘制非客户区消息
procedure WMNCPaint(var message: TWMNCPaint); message WM_NCPAINT;
// 在激活程序时需要相应的消息
procedure WMNCActivate(var Message: TMessage); message WM_NCACTIVATE;
// 鼠标按下时需要控制系统响应绘制
procedure WMNCLButtonDown(var Message: TWMNCHitMessage); message WM_NCLBUTTONDOWN;
// 下面这2个消息是Windows内部Bug处理，直接屏蔽处理（winxp下有）
procedure WMNCUAHDrawCaption(var Message: TMessage); message WM_NCUAHDRAWCAPTION;
procedure WMNCUAHDrawFrame(var Message: TMessage); message WM_NCUAHDRAWFRAME;

第一步直接覆盖WM_NCPAINT 消息进行外边框绘制。

会发现有2个问题：

  1、点击右上角的系统按钮区域会出现系统按钮

  2、当切换程序的时候窗体会恢复默认样式。

需要处理WM_NCACTIVATE 和 WM_NCLBUTTONDOWN 这两个消息，解决上面2个问题。

如果你是Win7或以上，那么恭喜！埋了个Bug。在WinXP下使用Spy++会出现下面消息

1 <00003> 00140124 S WM_NCHITTEST xPos:557 yPos:182
<00004> 00140124 R WM_NCHITTEST nHittest:HTTOPRIGHT
<00005> 00140124 S WM_SETCURSOR hwnd:00140124 nHittest:HTTOPRIGHT wMouseMsg:WM_MOUSEMOVE
<00006> 00140124 S message:0x00AE [未知] wParam:00001000 lParam:00000000
<00007> 00140124 R message:0x00AE [未知] lResult:00000000
<00008> 00140124 R WM_SETCURSOR fHaltProcessing:True
<00009> 00140124 P WM_NCMOUSEMOVE nHittest:HTTOPRIGHT xPos:557 yPos:182

Message:0x00AE 这个隐秘的消息，会让系统按钮重现江湖。网上查了下是Windows的Bug处理。由于是自己控制绘制，所以直接可以丢弃此消息。另外还有个0x00AF的消息也一样处理。

通过上面5个消息，基本实现非客户区的绘制。现在怎么动都不会出现恢复系统样式问题。

有全白的是正好切换到记事本，里面没内容。

unit ufrmCaptionToolbar;

interface

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

type
  TTest = class
  strict private const
    WM_NCUAHDRAWCAPTION = $00AE;
    WM_NCUAHDRAWFRAME = $00AF;
  private
    FControl: TWinControl;
    //FFormActive: Boolean;
    FHandled: Boolean;

    function  GetHandle: HWND;
    function GetForm: TCustomForm; inline;

    procedure WMNCPaint(var message: TWMNCPaint); message WM_NCPAINT;
    procedure WMNCActivate(var Message: TMessage); message WM_NCACTIVATE;
    procedure WMNCUAHDrawCaption(var Message: TMessage); message WM_NCUAHDRAWCAPTION;
    procedure WMNCUAHDrawFrame(var Message: TMessage); message WM_NCUAHDRAWFRAME;
    procedure WMNCLButtonDown(var Message: TWMNCHitMessage); message WM_NCLBUTTONDOWN;

    procedure WndProc(var message: TMessage);
  protected
    property Handle: HWND read GetHandle;
    procedure InvalidateNC;
    procedure PaintNC(ARGN: HRGN = 0);
  public
    constructor Create(AOwner: TWinControl);
    property Handled: Boolean read FHandled write FHandled;
    property Control: TWinControl read FControl;
    property Form: TCustomForm read GetForm;
  end;

  TForm11 = class(TForm)
  private
    FTest: TTest;
  protected
    function DoHandleMessage(var message: TMessage): Boolean;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

var
  Form11: TForm11;

implementation

{$R *.dfm}

{ TForm11 }

constructor TForm11.Create(AOwner: TComponent);
begin
  FTest := TTest.Create(Self);
  inherited;
end;

destructor TForm11.Destroy;
begin
  inherited;
  FreeAndNil(FTest);
end;

function TForm11.DoHandleMessage(var message: TMessage): Boolean;
begin
  FTest.WndProc(message);
  Result := FTest.Handled;
end;

procedure TForm11.WndProc(var Message: TMessage);
begin
  if not DoHandleMessage(Message) then
    inherited;
end;

constructor TTest.Create(AOwner: TWinControl);
begin
  FControl := AOwner;
end;

function TTest.GetForm: TCustomForm;
begin
  Result := TCustomForm(Control);
end;

function TTest.GetHandle: HWND;
begin
  if FControl.HandleAllocated then
    Result := FControl.Handle
  else
    Result := 0;
end;

procedure TTest.InvalidateNC;
begin
  if FControl.HandleAllocated then
    SendMessage(Handle, WM_NCPAINT, 0, 0);
end;

procedure TTest.PaintNC(ARGN: HRGN = 0);
var
  DC: HDC;
  Flags: cardinal;
  hb: HBRUSH;
  P: TPoint;
  r: TRect;
begin
  Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE;
  if (ARgn = 1) then
    DC := GetDCEx(Handle, 0, Flags)
  else
    DC := GetDCEx(Handle, ARgn, Flags or DCX_INTERSECTRGN);

  if DC <> 0 then
  begin
    P := Point(0, 0);
    Windows.ClientToScreen(Handle, P);
    Windows.GetWindowRect(Handle, R);
    P.X := P.X - R.Left;
    P.Y := P.Y - R.Top;
    Windows.GetClientRect(Handle, R);

    ExcludeClipRect(DC, P.X, P.Y, R.Right - R.Left + P.X, R.Bottom - R.Top + P.Y);

    GetWindowRect(handle, r);
    OffsetRect(R, -R.Left, -R.Top);

    hb := CreateSolidBrush($00bf7b18);
    FillRect(dc, r, hb);
    DeleteObject(hb);

    SelectClipRgn(DC, 0);

    ReleaseDC(Handle, dc);
  end;
end;

procedure TTest.WMNCActivate(var Message: TMessage);
begin
  //FFormActive := Message.WParam > 0;
  Message.Result := 1;
  InvalidateNC;
  Handled := True;
end;

procedure TTest.WMNCLButtonDown(var Message: TWMNCHitMessage);
begin
  inherited;

  if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or
     (Message.HitTest = HTMINBUTTON) or (Message.HitTest = HTHELP) then
  begin
    //FPressedButton := Message.HitTest;
    InvalidateNC;
    Message.Result := 0;
    Message.Msg := WM_NULL;
    Handled := True;
  end;
end;

procedure TTest.WMNCPaint(var message: TWMNCPaint);
begin
  PaintNC(message.RGN);
  Handled := True;
end;

procedure TTest.WMNCUAHDrawCaption(var Message: TMessage);
begin
  ///  这个消息会在winxp下产生，是内部Bug处理，直接丢弃此消息
  Handled := True;
end;

procedure TTest.WMNCUAHDrawFrame(var Message: TMessage);
begin
  ///  这个消息会在winxp下产生，是内部Bug处理，直接丢弃此消息
  Handled := True;
end;

procedure TTest.WndProc(var message: TMessage);
begin
  FHandled := False;
  Dispatch(message);
end;

end.

开发环境：

    XE3

    win7

蘑菇房 (moguf.com)