• 窗体皮肤实现


    窗体边框基本的绘制和控制完成,在第二篇中主要遗留的问题。

    • 标题区域图标和按钮没绘制
    • 缩放时客户区显示有问题

     解决完下面的问题,皮肤处理基本完整。大致的效果GIF

     GIF中TShape的颜色表现有些问题,实际是正常的。

    绘制标题区域内容

    1. 获取标题有效区域
    2. 绘制窗体图标
    3. 绘制按钮
    4. 绘制标题

      标题区域主要考虑窗体是否在最大化状态,最大化后实际的标题绘制区域会有变化。可以通过 IsZoomed 或 GetWindowLong(Handle, GWL_STYLE) and WS_MAXIMIZE = WS_MAXIMIZE 的方式获取。

     1 AMaxed := IsZoomed(Handle);    // 获取窗体最大化状态
     2 
     3 function TTest.GetCaptionRect(AMaxed: Boolean): TRect;
     4 var
     5   rFrame: TRect;
     6 begin
     7   rFrame := GetFrameSize;         // 窗体上下左右的边框尺寸
     8   // 最大化状态简易处理
     9   if AMaxed then
    10     Result := Rect(8, 8, FWidth - 9 , rFrame.Top)
    11   else
    12     Result := Rect(rFrame.Left, 3, FWidth - rFrame.right, rFrame.Top);
    13 end;

    绘制窗体图标稍微有些麻烦,需要获取窗体的Icon图标。窗体图标并不一定是程序图标。主要过程通过WM_GETICON 这个消息获取图标。

    1   TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0));
    2   if TmpHandle = 0 then
    3     TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0));

    如果上述方法无法获得,需要通过GetClassName 和 GetClassInfoEx 这2个API获取。

     1 { Get instance }
     2 GetClassName(Handle, @Buffer, SizeOf(Buffer));
     3 FillChar(Info, SizeOf(Info), 0);
     4 Info.cbSize := SizeOf(Info);
     5 
     6 if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then
     7 begin
     8   TmpHandle := Info.hIconSm;
     9   if TmpHandle = 0 then
    10     TmpHandle := Info.HICON;
    11 end

      上述这2种方法还是无法获取。那~~ 就没有办法了。如果非要绘制图标可以使用Application的图标进行代替。

    1 Application.Icon.Handle
     1 function TTest.GetIcon: TIcon;
     2 var
     3   IconX, IconY: integer;
     4   TmpHandle: THandle;
     5   Info: TWndClassEx;
     6   Buffer: array [0 .. 255] of Char;
     7 begin
     8   ///
     9   /// 获取当前form的图标
    10   /// 这个图标和App的图标是不同的
    11   ///
    12   TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0));
    13   if TmpHandle = 0 then
    14     TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0));
    15 
    16   if TmpHandle = 0 then
    17   begin
    18     { Get instance }
    19     GetClassName(Handle, @Buffer, SizeOf(Buffer));
    20     FillChar(Info, SizeOf(Info), 0);
    21     Info.cbSize := SizeOf(Info);
    22 
    23     if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then
    24     begin
    25       TmpHandle := Info.hIconSm;
    26       if TmpHandle = 0 then
    27         TmpHandle := Info.HICON;
    28     end
    29   end;
    30 
    31   if FIcon = nil then
    32     FIcon := TIcon.Create;
    33 
    34   if TmpHandle <> 0 then
    35   begin
    36     IconX := GetSystemMetrics(SM_CXSMICON);
    37     if IconX = 0 then
    38       IconX := GetSystemMetrics(SM_CXSIZE);
    39     IconY := GetSystemMetrics(SM_CYSMICON);
    40     if IconY = 0 then
    41       IconY := GetSystemMetrics(SM_CYSIZE);
    42     FIcon.Handle := CopyImage(TmpHandle, IMAGE_ICON, IconX, IconY, 0);
    43     FIconHandle := TmpHandle;
    44   end;
    45 
    46   Result := FIcon;
    47 end;
    完整获取窗体图标的方法

    绘制系统最小化、最大化和关闭按钮直接使用贴图的方法。做一张PNG图片,做成资源文件加入到单元中。

    注:图标是白色的没底色看不见,所以在贴的图上加了个黑底。

    计算好实际位置后,直接把从资源中加载的图标绘制上去。

     1 procedure TTest.DrawButton(DC: HDC; AKind: TFormButtonKind; AState: TSkinIndicator; const R: TRect);
     2 var
     3   hB: HBRUSH;
     4   iColor: Cardinal;
     5   rSrcOff: TPoint;
     6   x, y: integer;
     7 begin
     8   /// 绘制背景
     9   case AState of
    10     siHover         : iColor := SKINCOLOR_BTNHOT;
    11     siPressed       : iColor := SKINCOLOR_BTNPRESSED;
    12     siSelected      : iColor := SKINCOLOR_BTNPRESSED;
    13     siHoverSelected : iColor := SKINCOLOR_BTNHOT;
    14   else                iColor := SKINCOLOR_BAKCGROUND;
    15   end;
    16   hB := CreateSolidBrush(iColor);
    17   FillRect(DC, R, hB);
    18   DeleteObject(hB);
    19 
    20   /// 绘制图标
    21   rSrcOff := Point(SIZE_RESICON * ord(AKind), 0);
    22   x := R.Left + (R.Right - R.Left - SIZE_RESICON) div 2;
    23   y := R.Top + (R.Bottom - R.Top - SIZE_RESICON) div 2;
    24   DrawTransparentBitmap(FSkinData, rSrcOff.X, rSrcOff.Y, DC, x, y, SIZE_RESICON, SIZE_RESICON);
    25 end;

    最后绘制标题,设置背景SetBkMode透明,设置字体颜色SetTextColor为白色。

    1 /// 绘制Caption
    2 sData :=  GetCaption;
    3 SetBkMode(DC, TRANSPARENT);
    4 SaveColor := SetTextColor(DC, $00FFFFFF);
    5 Flag := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
    6 DrawTextEx(DC, PChar(sData), Length(sData), rCaptionRect, Flag, nil);
    7 SetTextColor(DC, SaveColor);

    整个标题区域就绘制完成。

     标题区按钮响应鼠标消息

    基本的绘制完成,鼠标滑到窗体按钮区域(最大化、最小化和关闭)和点击并不会相应。需要自己处理相应的消息。WM_NCHITTEST 消息是系统用来确定鼠标位置对应的窗体区域,可以通过这个消息实现对窗体按钮的相应。

    为实现窗体按钮的响应,只要处理这个区域。其他区域消息还是交由窗体原有消息处理。

    相应两种状态: 滑入时的显示样式、按下时的显示样式。

     1 procedure TTest.WMNCHitTest(var Message: TWMNCHitTest);
     2 var
     3   P: TPoint;
     4   iHit: integer;
     5 begin
     6   // 需要把位置转换到实际窗口位置
     7   P := NormalizePoint(Point(Message.XPos, Message.YPos));
     8 
     9   // 获取 位置
    10   // 只对监控区域处理,其他由系统处理
    11   iHit := HitTest(p);
    12   if FHotHit > HTNOWHERE then
    13   begin
    14     Message.Result := iHit;
    15     Handled := True;            // 处理完成,不再交由系统处理
    16   end;
    17   
    18   // 响应鼠标滑入监控区域后,通知非客户区重绘
    19   if iHit <> FHotHit then
    20   begin
    21     FHotHit := iHit;
    22     InvalidateNC;
    23   end;
    24 end;
     1 function TTest.HitTest(P: TPoint):integer;
     2 var
     3   bMaxed: Boolean;
     4   r: TRect;
     5   rCaptionRect: TRect;
     6   rFrame: TRect;
     7 begin
     8   Result := HTNOWHERE;
     9 
    10   ///
    11   /// 检测位置
    12   ///
    13   rFrame := GetFrameSize;
    14   if p.Y > rFrame.Top then
    15     Exit;
    16 
    17   ///
    18   ///  只关心窗体按钮区域
    19   ///
    20   bMaxed := IsZoomed(Handle);
    21   rCaptionRect := GetCaptionRect(bMaxed);
    22   if PtInRect(rCaptionRect, p) then
    23   begin
    24     r.Right := rCaptionRect.Right - 1;
    25     r.Top := 0;
    26     if bMaxed then
    27       r.Top := rCaptionRect.Top;
    28     r.Top := r.Top + (rFrame.Top - r.Top - SIZE_SYSBTN.cy) div 2;
    29     r.Left := r.Right - SIZE_SYSBTN.cx;
    30     r.Bottom := r.Top + SIZE_SYSBTN.cy;
    31 
    32     ///
    33     /// 实际绘制的按钮就三个,其他没处理
    34     ///
    35     if (P.Y >= r.Top) and (p.Y <= r.Bottom) and (p.X <= r.Right) then
    36     begin
    37       if (P.X >= r.Left) then
    38         Result := HTCLOSE
    39       else if p.X >= (r.Left - SIZE_SYSBTN.cx) then
    40         Result := HTMAXBUTTON
    41       else if p.X >= (r.Left - SIZE_SYSBTN.cx * 2) then
    42         Result := HTMINBUTTON;
    43     end;
    44   end;
    45 end;
    function HitTest(P: TPoint):integer

    上面代码获取当前鼠标所在位置,这样滑入的Hot状态信息已经获取。还个是记录按下的状态,需要使用WM_NCLBUTTONDOWN消息获得鼠标按下后的位置来实现。

     1 procedure TTest.WMNCLButtonDown(var message: TWMNCHitMessage);
     2 var
     3   iHit: integer;
     4 begin
     5   // 对监控的区域作相应
     6   iHit := HTNOWHERE;
     7   if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or (Message.HitTest = HTMINBUTTON) or
     8     (Message.HitTest = HTHELP) then
     9   begin
    10     iHit := Message.HitTest;
    11     Message.Result := 0;
    12     Message.Msg := WM_NULL;
    13     Handled := True;           // 消息已经处理完成,不再交由系统处理
    14   end;
    15 
    16   // 如果按下的位置发生变化,重绘标题区
    17   if iHit <> FPressedHit then
    18   begin
    19     FPressedHit := iHit;
    20     InvalidateNC;
    21   end;
    22 end;

    通过上述两个消息,获取到鼠标所在按钮的位置。在绘制标题区函数中直接使用。

     1 // 注意:
     2 //   按钮样式枚举的顺序不要颠倒,这个和资源图标的排列顺序是一致的
     3 TFormButtonKind = (fbkMin, fbkMax, fbkRestore, fbkClose, fbkHelp);
     4 
     5 procedure TTest.PaintNC(DC: HDC);
     6 const
     7   HITVALUES: array [TFormButtonKind] of integer = (HTMINBUTTON, HTMAXBUTTON, HTMAXBUTTON, HTCLOSE, HTHELP);
     8 
     9   function GetBtnState(AKind: TFormButtonKind): TSkinIndicator;
    10   begin
    11     // 按下区域 一定和 Hot区域一致,保证鼠标点击到弹起的区域是一致,才能执行
    12     if (FPressedHit = FHotHit) and (FPressedHit = HITVALUES[AKind]) then
    13       Result := siPressed
    14     else if FHotHit = HITVALUES[AKind] then
    15       Result := siHover
    16     else
    17       Result := siInactive;
    18   end;
    19 
    20   ... ...
    21 begin
    22     ... ...
    23     // 绘制 关闭按钮
    24     DrawButton(Dc, fbkClose, GetBtnState(fbkClose), rButton);
    25 
    26     ... ...
    27 end;

    上述的绘制相应已经完成,但鼠标点击是不会有任何反应的。需要处理WM_NCLBUTTONUP消息

     1 procedure TTest.WMNCLButtonUp(var Message: TWMNCHitMessage);
     2 var
     3   iWasHit: Integer;
     4 begin
     5   iWasHit := FPressedHit;
     6 
     7   // 处理监控区域的鼠标弹起消息
     8   if iWasHit <> HTNOWHERE then
     9   begin
    10     FPressedHit := HTNOWHERE;
    11     //InvalidateNC;
    12 
    13     if iWasHit = FHotHit then
    14     begin
    15       case Message.HitTest of
    16         HTCLOSE     : SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0);
    17         HTMAXBUTTON : Maximize;
    18         HTMINBUTTON : Minimize;
    19         HTHELP      : SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0);
    20       end;
    21 
    22       Message.Result := 0;
    23       Message.Msg := WM_NULL;
    24       Handled := True;           // 消息已经处理完成,不需要控件再处理
    25     end;
    26   end;
    27 end;
     1 procedure TTest.Maximize;
     2 begin
     3   if Handle <> 0 then
     4   begin
     5     FPressedHit := 0;
     6     FHotHit := 0;
     7     if IsZoomed(Handle) then
     8       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
     9     else
    10       SendMessage(Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0);
    11   end;
    12 end;
    13 
    14 procedure TTest.Minimize;
    15 begin
    16   if Handle <> 0 then
    17   begin
    18     FPressedHit := 0;
    19     FHotHit := 0;
    20     if IsIconic(Handle) then
    21       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
    22     else
    23       SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
    24    end;
    25 end;
    fun Maximize Minimize

    整个标题区的消息基本处理完成,能正常相应标题区应有的功能。还有些细节上面需要处理一下,如修改窗体标题没有及时响应。WM_SETTEXT消息用于处理标题修改。

    1 procedure TTest.WMSetText(var Message: TMessage);
    2 begin
    3   CallDefaultProc(Message);   // 优先有系统处理此消息
    4   InvalidateNC;               // 重绘标题区
    5   Handled := true;
    6 end;

    绘制客户区

      还有最后一个问题。在缩放窗体时,客户区惨不忍睹。其实这个还是比较简单,处理擦除背景(WM_ERASEBKGND)和响应绘制(WM_PAINT)消息就能完成。

     擦除处理 

     1 procedure TTest.WMEraseBkgnd(var message: TWMEraseBkgnd);
     2 var
     3   DC: HDC;
     4   SaveIndex: integer;
     5 begin
     6   DC := Message.DC;
     7   if DC <> 0 then
     8   begin
     9     // 如果是容器控件,擦除一定要处理。填色也行。
    10     // 否则会出现因主绘制延迟,出现短暂的未刷新色块残留。特别在使用Buffer方式绘制时常出现
    11     SaveIndex := SaveDC(DC);
    12     PaintBackground(DC);
    13     RestoreDC(DC, SaveIndex);
    14   end;
    15 
    16   Handled := True;       // 消息处理完成,控件不再处理
    17   Message.Result := 1;   // 绘制结束,外部不用处理
    18 end;

    绘制客户区,需要通知子控件刷新。

     1 procedure TTest.WMPaint(var message: TWMPaint);
     2 var
     3   DC, hPaintDC: HDC;
     4   cBuffer: TBitmap;
     5   PS: TPaintStruct;
     6 begin
     7   ///
     8   /// 绘制客户区域
     9   ///
    10   DC := Message.DC;
    11 
    12   hPaintDC := DC;
    13   if DC = 0 then
    14     hPaintDC := BeginPaint(Handle, PS);
    15 
    16   if DC = 0 then
    17   begin
    18     /// 缓冲模式绘制,减少闪烁
    19     cBuffer := TBitmap.Create;
    20     try
    21       cBuffer.SetSize(FWidth, FHeight);
    22       PaintBackground(cBuffer.Canvas.Handle);
    23       Paint(cBuffer.Canvas.Handle);
    24       /// 通知子控件进行绘制
    25       /// 主要是些图形控件的重绘制(如TShape),否则停靠在Form上的图像控件无法正常显示
    26       if Control is TWinControl then
    27         TacWinControl(Control).PaintControls(cBuffer.Canvas.Handle, nil);
    28       BitBlt(hPaintDC, 0, 0, FWidth, FHeight, cBuffer.Canvas.Handle, 0, 0, SRCCOPY);
    29     finally
    30       cBuffer.Free;
    31     end;
    32   end
    33   else
    34   begin
    35     Paint(hPaintDC);
    36     // 通知子控件重绘
    37     if Control is TWinControl then
    38       TacWinControl(Control).PaintControls(hPaintDC, nil);
    39   end;
    40 
    41   if DC = 0 then
    42     EndPaint(Handle, PS);
    43 
    44   Handled := True;
    45 end;

    其中的Paint不需要处理任何代码。

    procedure TTest.Paint(DC: HDC);
    begin
      // 不需要处理。
    end;

    基本的窗体绘制控制基本完成。

    现在时下流行的换肤,还是比较容易实现。增加一块背景图资源,在绘制时算好位置贴上去就OK。还有一些鼠标滑入按钮的渐变效果,可以创建一个时钟记录每个按钮的背景褪色值(透明度)使用AlphaBlend 这个函数进行绘制,或是用混色的方法处理。

     1 procedure DrawTransparentBitmap(Source: TBitmap; sx, sy: Integer; Destination: HDC;
     2   const dX, dY: Integer;  w, h: Integer; const Opacity: Byte = 255); overload;
     3 var
     4   BlendFunc: TBlendFunction;
     5 begin
     6   BlendFunc.BlendOp := AC_SRC_OVER;
     7   BlendFunc.BlendFlags := 0;
     8   BlendFunc.SourceConstantAlpha := Opacity;
     9 
    10   if Source.PixelFormat = pf32bit then
    11     BlendFunc.AlphaFormat := AC_SRC_ALPHA
    12   else
    13     BlendFunc.AlphaFormat := 0;
    14 
    15   AlphaBlend(Destination, dX, dY, w, h, Source.Canvas.Handle, sx, sy, w, h, BlendFunc);
    16 end;
    通过透明度控制背景动画效果,参考DrawTransparentBitmap

    感觉XE3有些伤不起,Release版本的exe竟然要2.42M。哎~。看来要搞个C版的。

      1 unit ufrmCaptionToolbar;
      2 
      3 interface
      4 
      5 uses
      6   Messages, SysUtils, Variants, Types, Controls, Forms, Dialogs, StdCtrls,
      7   ExtCtrls,
      8   ComCtrls,
      9   Windows,  // 这个单元放在 ComCtrls 的后面,HITTEST 的定义重名。大小写不敏感真的很不方便
     10   Classes, Graphics,
     11   pngimage, Actions, ActnList, ToolWin, Vcl.ImgList, Vcl.Buttons;
     12 
     13 type
     14   TFormButtonKind = (fbkMin, fbkMax, fbkRestore, fbkClose, fbkHelp);
     15   TSkinIndicator = (siInactive, siHover, siPressed, siSelected, siHoverSelected);
     16 
     17   TTest = class
     18   strict private
     19   const
     20     WM_NCUAHDRAWCAPTION = $00AE;
     21   private
     22     FCallDefaultProc: Boolean;
     23     FChangeSizeCalled: Boolean;
     24     FControl: TWinControl;
     25     FHandled: Boolean;
     26 
     27     FRegion: HRGN;
     28     FLeft: integer;
     29     FTop: integer;
     30     FWidth: integer;
     31     FHeight: integer;
     32 
     33     /// 窗体图标
     34     FIcon: TIcon;
     35     FIconHandle: HICON;
     36 
     37     //
     38     FPressedHit: Integer;     // 实际按下的位置, (只处理关心的位置,其他有交由系统处理)
     39     FHotHit: integer;         // 记录上次的测试位置 (只处理关心的位置,其他有交由系统处理)
     40 
     41     // skin
     42     //  这个内容应独立出来,作为单独一份配置应用于所有窗体。
     43     FSkinData: TBitmap;
     44     procedure DrawButton(DC: HDC; AKind: TFormButtonKind; AState: TSkinIndicator; const R: TRect);
     45 
     46     function GetHandle: HWND; inline;
     47     function GetForm: TCustomForm; inline;
     48     function GetFrameSize: TRect;
     49     function GetCaptionRect(AMaxed: Boolean): TRect; inline;
     50     function GetCaption: string;
     51     function GetIcon: TIcon;
     52     function GetIconFast: TIcon;
     53 
     54     procedure ChangeSize;
     55     function  NormalizePoint(P: TPoint): TPoint;
     56     function  HitTest(P: TPoint):integer;
     57     procedure Maximize;
     58     procedure Minimize;
     59 
     60     // 第一组 实现绘制基础
     61     procedure WMNCPaint(var message: TWMNCPaint); message WM_NCPAINT;
     62     procedure WMNCActivate(var message: TMessage); message WM_NCACTIVATE;
     63     procedure WMNCLButtonDown(var message: TWMNCHitMessage); message WM_NCLBUTTONDOWN;
     64     procedure WMNCUAHDrawCaption(var message: TMessage); message WM_NCUAHDRAWCAPTION;
     65 
     66     // 第二组 控制窗体样式
     67     procedure WMNCCalcSize(var message: TWMNCCalcSize); message WM_NCCALCSIZE;
     68     procedure WMWindowPosChanging(var message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
     69 
     70     // 第三组 绘制背景和内部控件
     71     procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
     72     procedure WMPaint(var message: TWMPaint); message WM_PAINT;
     73 
     74     // 第四组 控制按钮状态
     75     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
     76     procedure WMNCLButtonUp(var Message: TWMNCHitMessage); message WM_NCLBUTTONUP;
     77     procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE;
     78 
     79     procedure WMSetText(var Message: TMessage); message WM_SETTEXT;
     80 
     81     procedure WndProc(var message: TMessage);
     82     procedure CallDefaultProc(var message: TMessage);
     83 
     84   protected
     85     property  Handle: HWND read GetHandle;
     86     procedure InvalidateNC;
     87     procedure PaintNC(DC: HDC);
     88     procedure PaintBackground(DC: HDC);
     89     procedure Paint(DC: HDC);
     90 
     91   public
     92     constructor Create(AOwner: TWinControl);
     93     destructor Destroy; override;
     94 
     95     property Handled: Boolean read FHandled write FHandled;
     96     property Control: TWinControl read FControl;
     97     property Form: TCustomForm read GetForm;
     98 
     99   end;
    100 
    101   TForm11 = class(TForm)
    102     Button1: TButton;
    103     Shape1: TShape;
    104     Edit1: TEdit;
    105     Edit2: TEdit;
    106     Edit3: TEdit;
    107     Edit4: TEdit;
    108     ToolBar1: TToolBar;
    109     ToolButton1: TToolButton;
    110     ToolButton2: TToolButton;
    111     ToolButton3: TToolButton;
    112     ActionList1: TActionList;
    113     Action1: TAction;
    114     Action2: TAction;
    115     Action3: TAction;
    116     ImageList1: TImageList;
    117     procedure Action1Execute(Sender: TObject);
    118     procedure Action2Execute(Sender: TObject);
    119     procedure SpeedButton1Click(Sender: TObject);
    120   private
    121     FTest: TTest;
    122   protected
    123     function DoHandleMessage(var message: TMessage): Boolean;
    124     procedure WndProc(var message: TMessage); override;
    125   public
    126     constructor Create(AOwner: TComponent); override;
    127     destructor Destroy; override;
    128   end;
    129 
    130   Res = class
    131     class procedure LoadGraphic(const AName: string; AGraphic: TGraphic);
    132     class procedure LoadBitmap(const AName: string; AGraphic: TBitmap);
    133   end;
    134 
    135 var
    136   Form11: TForm11;
    137 
    138 implementation
    139 
    140 const
    141   SKINCOLOR_BAKCGROUND  = $00BF7B18;  // 背景色
    142   SKINCOLOR_BTNHOT      = $00F2D5C2;  // Hot 激活状态
    143   SKINCOLOR_BTNPRESSED  = $00E3BDA3;  // 按下状态
    144   SIZE_SYSBTN: TSize    = (cx: 29; cy: 18);
    145   SIZE_FRAME: TRect     = (Left: 4; Top: 28; Right: 5; Bottom: 5); // 窗体边框的尺寸
    146   SPACE_AREA            = 3;          // 功能区域之间间隔
    147   SIZE_RESICON          = 16;         // 资源中图标默认尺寸
    148 
    149 
    150 {$R *.dfm}
    151 {$R MySkin.RES}
    152 
    153 type
    154   TacWinControl = class(TWinControl);
    155 
    156 function BuildRect(L, T, W, H: Integer): TRect; inline;
    157 begin
    158   Result := Rect(L, T, L + W, T + H);
    159 end;
    160 
    161 procedure DrawTransparentBitmap(Source: TBitmap; sx, sy: Integer; Destination: HDC;
    162   const dX, dY: Integer;  w, h: Integer; const Opacity: Byte = 255); overload;
    163 var
    164   BlendFunc: TBlendFunction;
    165 begin
    166   BlendFunc.BlendOp := AC_SRC_OVER;
    167   BlendFunc.BlendFlags := 0;
    168   BlendFunc.SourceConstantAlpha := Opacity;
    169 
    170   if Source.PixelFormat = pf32bit then
    171     BlendFunc.AlphaFormat := AC_SRC_ALPHA
    172   else
    173     BlendFunc.AlphaFormat := 0;
    174 
    175   AlphaBlend(Destination, dX, dY, w, h, Source.Canvas.Handle, sx, sy, w, h, BlendFunc);
    176 end;
    177 
    178 class procedure Res.LoadBitmap(const AName: string; AGraphic: TBitmap);
    179 var
    180   cPic: TPngImage;
    181   cBmp: TBitmap;
    182 begin
    183   cBmp := AGraphic;
    184   cPic := TPngImage.Create;
    185   try
    186     cBmp.PixelFormat := pf32bit;
    187     cBmp.alphaFormat := afIgnored;
    188     try
    189       LoadGraphic(AName, cPic);
    190       cBmp.SetSize(cPic.Width, cPic.Height);
    191       cBmp.Canvas.Brush.Color := clBlack;
    192       cBmp.Canvas.FillRect(Rect(0, 0, cBmp.Width, cBmp.Height));
    193       cBmp.Canvas.Draw(0, 0, cPic);
    194     except
    195       // 不处理空图片
    196     end;
    197   finally
    198     cPic.Free;
    199   end;
    200 end;
    201 
    202 class procedure Res.LoadGraphic(const AName: string; AGraphic: TGraphic);
    203 var
    204   cStream: TResourceStream;
    205   h: THandle;
    206 begin
    207   ///
    208   /// 加载图片资源
    209   h := HInstance;
    210   cStream := TResourceStream.Create(h, AName, RT_RCDATA);
    211   try
    212     AGraphic.LoadFromStream(cStream);
    213   finally
    214     cStream.Free;
    215   end;
    216 end;
    217 
    218 { TForm11 }
    219 
    220 constructor TForm11.Create(AOwner: TComponent);
    221 begin
    222   FTest := TTest.Create(Self);
    223   inherited;
    224 end;
    225 
    226 destructor TForm11.Destroy;
    227 begin
    228   inherited;
    229   FreeAndNil(FTest);
    230 end;
    231 
    232 procedure TForm11.Action1Execute(Sender: TObject);
    233 begin
    234   Tag := Tag + 1;
    235   Caption := format('test %d', [Tag]);
    236 end;
    237 
    238 procedure TForm11.Action2Execute(Sender: TObject);
    239 begin
    240   if Shape1.Shape <> High(TShapeType) then
    241     Shape1.Shape := Succ(Shape1.Shape)
    242   else
    243     Shape1.Shape := low(TShapeType);
    244 end;
    245 
    246 function TForm11.DoHandleMessage(var message: TMessage): Boolean;
    247 begin
    248   Result := False;
    249   if not FTest.FCallDefaultProc then
    250   begin
    251     FTest.WndProc(message);
    252     Result := FTest.Handled;
    253   end;
    254 end;
    255 
    256 procedure TForm11.SpeedButton1Click(Sender: TObject);
    257 begin
    258   Caption := format('test %d', [1]);
    259 end;
    260 
    261 procedure TForm11.WndProc(var message: TMessage);
    262 begin
    263   if not DoHandleMessage(Message) then
    264     inherited;
    265 end;
    266 
    267 procedure TTest.CallDefaultProc(var message: TMessage);
    268 begin
    269   if FCallDefaultProc then
    270     FControl.WindowProc(message)
    271   else
    272   begin
    273     FCallDefaultProc := True;
    274     FControl.WindowProc(message);
    275     FCallDefaultProc := False;
    276   end;
    277 end;
    278 
    279 procedure TTest.ChangeSize;
    280 var
    281   hTmp: HRGN;
    282 begin
    283   /// 设置窗体外框样式
    284   FChangeSizeCalled := True;
    285   try
    286     hTmp := FRegion;
    287     try
    288       /// 创建矩形外框,3的倒角
    289       FRegion := CreateRoundRectRgn(0, 0, FWidth, FHeight, 3, 3);
    290       SetWindowRgn(Handle, FRegion, True);
    291     finally
    292       if hTmp <> 0 then
    293         DeleteObject(hTmp);
    294     end;
    295   finally
    296     FChangeSizeCalled := False;
    297   end;
    298 end;
    299 
    300 function TTest.NormalizePoint(P: TPoint): TPoint;
    301 var
    302   rWindowPos, rClientPos: TPoint;
    303 begin
    304   rWindowPos := Point(FLeft, FTop);
    305   rClientPos := Point(0, 0);
    306   ClientToScreen(Handle, rClientPos);
    307   Result := P;
    308   ScreenToClient(Handle, Result);
    309   Inc(Result.X, rClientPos.X - rWindowPos.X);
    310   Inc(Result.Y, rClientPos.Y - rWindowPos.Y);
    311 end;
    312 
    313 function TTest.HitTest(P: TPoint):integer;
    314 var
    315   bMaxed: Boolean;
    316   r: TRect;
    317   rCaptionRect: TRect;
    318   rFrame: TRect;
    319 begin
    320   Result := HTNOWHERE;
    321 
    322   ///
    323   /// 检测位置
    324   ///
    325   rFrame := GetFrameSize;
    326   if p.Y > rFrame.Top then
    327     Exit;
    328 
    329   ///
    330   ///  只关心窗体按钮区域
    331   ///
    332   bMaxed := IsZoomed(Handle);
    333   rCaptionRect := GetCaptionRect(bMaxed);
    334   if PtInRect(rCaptionRect, p) then
    335   begin
    336     r.Right := rCaptionRect.Right - 1;
    337     r.Top := 0;
    338     if bMaxed then
    339       r.Top := rCaptionRect.Top;
    340     r.Top := r.Top + (rFrame.Top - r.Top - SIZE_SYSBTN.cy) div 2;
    341     r.Left := r.Right - SIZE_SYSBTN.cx;
    342     r.Bottom := r.Top + SIZE_SYSBTN.cy;
    343 
    344     ///
    345     /// 实际绘制的按钮就三个,其他没处理
    346     ///
    347     if (P.Y >= r.Top) and (p.Y <= r.Bottom) and (p.X <= r.Right) then
    348     begin
    349       if (P.X >= r.Left) then
    350         Result := HTCLOSE
    351       else if p.X >= (r.Left - SIZE_SYSBTN.cx) then
    352         Result := HTMAXBUTTON
    353       else if p.X >= (r.Left - SIZE_SYSBTN.cx * 2) then
    354         Result := HTMINBUTTON;
    355     end;
    356   end;
    357 end;
    358 
    359 constructor TTest.Create(AOwner: TWinControl);
    360 begin
    361   FControl := AOwner;
    362   FRegion := 0;
    363   FChangeSizeCalled := False;
    364   FCallDefaultProc := False;
    365 
    366   FWidth := FControl.Width;
    367   FHeight := FControl.Height;
    368   FIcon := nil;
    369   FIconHandle := 0;
    370 
    371   // 加载资源
    372   FSkinData := TBitmap.Create;
    373   Res.LoadBitmap('MySkin', FSkinData);
    374 end;
    375 
    376 destructor TTest.Destroy;
    377 begin
    378   FIconHandle := 0;
    379   if FSkinData <> nil then
    380     FreeAndNil(FSkinData);
    381   if FIcon <> nil then
    382     FreeAndNil(FIcon);
    383   if FRegion <> 0 then
    384     DeleteObject(FRegion);
    385   inherited;
    386 end;
    387 
    388 procedure TTest.DrawButton(DC: HDC; AKind: TFormButtonKind; AState: TSkinIndicator; const R: TRect);
    389 var
    390   hB: HBRUSH;
    391   iColor: Cardinal;
    392   rSrcOff: TPoint;
    393   x, y: integer;
    394 begin
    395   /// 绘制背景
    396   case AState of
    397     siHover         : iColor := SKINCOLOR_BTNHOT;
    398     siPressed       : iColor := SKINCOLOR_BTNPRESSED;
    399     siSelected      : iColor := SKINCOLOR_BTNPRESSED;
    400     siHoverSelected : iColor := SKINCOLOR_BTNHOT;
    401   else                iColor := SKINCOLOR_BAKCGROUND;
    402   end;
    403   hB := CreateSolidBrush(iColor);
    404   FillRect(DC, R, hB);
    405   DeleteObject(hB);
    406 
    407   /// 绘制图标
    408   rSrcOff := Point(SIZE_RESICON * ord(AKind), 0);
    409   x := R.Left + (R.Right - R.Left - SIZE_RESICON) div 2;
    410   y := R.Top + (R.Bottom - R.Top - SIZE_RESICON) div 2;
    411   DrawTransparentBitmap(FSkinData, rSrcOff.X, rSrcOff.Y, DC, x, y, SIZE_RESICON, SIZE_RESICON);
    412 end;
    413 
    414 function TTest.GetFrameSize: TRect;
    415 begin
    416   Result := SIZE_FRAME;
    417 end;
    418 
    419 function TTest.GetCaptionRect(AMaxed: Boolean): TRect;
    420 var
    421   rFrame: TRect;
    422 begin
    423   rFrame := GetFrameSize;
    424   // 最大化状态简易处理
    425   if AMaxed then
    426     Result := Rect(8, 8, FWidth - 9 , rFrame.Top)
    427   else
    428     Result := Rect(rFrame.Left, 3, FWidth - rFrame.right, rFrame.Top);
    429 end;
    430 
    431 function TTest.GetCaption: string;
    432 var
    433   Buffer: array [0..255] of Char;
    434   iLen: integer;
    435 begin
    436   if Handle <> 0 then
    437   begin
    438     iLen := GetWindowText(Handle, Buffer, Length(Buffer));
    439     SetString(Result, Buffer, iLen);
    440   end
    441   else
    442     Result := '';
    443 end;
    444 
    445 function TTest.GetForm: TCustomForm;
    446 begin
    447   Result := TCustomForm(Control);
    448 end;
    449 
    450 function TTest.GetHandle: HWND;
    451 begin
    452   if FControl.HandleAllocated then
    453     Result := FControl.Handle
    454   else
    455     Result := 0;
    456 end;
    457 
    458 function TTest.GetIcon: TIcon;
    459 var
    460   IconX, IconY: integer;
    461   TmpHandle: THandle;
    462   Info: TWndClassEx;
    463   Buffer: array [0 .. 255] of Char;
    464 begin
    465   ///
    466   /// 获取当前form的图标
    467   /// 这个图标和App的图标是不同的
    468   ///
    469   TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0));
    470   if TmpHandle = 0 then
    471     TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0));
    472 
    473   if TmpHandle = 0 then
    474   begin
    475     { Get instance }
    476     GetClassName(Handle, @Buffer, SizeOf(Buffer));
    477     FillChar(Info, SizeOf(Info), 0);
    478     Info.cbSize := SizeOf(Info);
    479 
    480     if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then
    481     begin
    482       TmpHandle := Info.hIconSm;
    483       if TmpHandle = 0 then
    484         TmpHandle := Info.HICON;
    485     end
    486   end;
    487 
    488   if FIcon = nil then
    489     FIcon := TIcon.Create;
    490 
    491   if TmpHandle <> 0 then
    492   begin
    493     IconX := GetSystemMetrics(SM_CXSMICON);
    494     if IconX = 0 then
    495       IconX := GetSystemMetrics(SM_CXSIZE);
    496     IconY := GetSystemMetrics(SM_CYSMICON);
    497     if IconY = 0 then
    498       IconY := GetSystemMetrics(SM_CYSIZE);
    499     FIcon.Handle := CopyImage(TmpHandle, IMAGE_ICON, IconX, IconY, 0);
    500     FIconHandle := TmpHandle;
    501   end;
    502 
    503   Result := FIcon;
    504 end;
    505 
    506 function TTest.GetIconFast: TIcon;
    507 begin
    508   if (FIcon = nil) or (FIconHandle = 0) then
    509     Result := GetIcon
    510   else
    511     Result := FIcon;
    512 end;
    513 
    514 procedure TTest.InvalidateNC;
    515 begin
    516   if FControl.HandleAllocated then
    517     SendMessage(Handle, WM_NCPAINT, 1, 0);
    518 end;
    519 
    520 procedure TTest.Maximize;
    521 begin
    522   if Handle <> 0 then
    523   begin
    524     FPressedHit := 0;
    525     FHotHit := 0;
    526     if IsZoomed(Handle) then
    527       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
    528     else
    529       SendMessage(Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0);
    530   end;
    531 end;
    532 
    533 procedure TTest.Minimize;
    534 begin
    535   if Handle <> 0 then
    536   begin
    537     FPressedHit := 0;
    538     FHotHit := 0;
    539     if IsIconic(Handle) then
    540       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
    541     else
    542       SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
    543    end;
    544 end;
    545 
    546 procedure TTest.PaintNC(DC: HDC);
    547 const
    548   HITVALUES: array [TFormButtonKind] of integer = (HTMINBUTTON, HTMAXBUTTON, HTMAXBUTTON, HTCLOSE, HTHELP);
    549 
    550   function GetBtnState(AKind: TFormButtonKind): TSkinIndicator;
    551   begin
    552     if (FPressedHit = FHotHit) and (FPressedHit = HITVALUES[AKind]) then
    553       Result := siPressed
    554     else if FHotHit = HITVALUES[AKind] then
    555       Result := siHover
    556     else
    557       Result := siInactive;
    558   end;
    559 
    560 var
    561   hB: HBRUSH;
    562   rFrame: TRect;
    563   rButton: TRect;
    564   SaveIndex: integer;
    565   bMaxed: Boolean;
    566   rCaptionRect : TRect;
    567   sData: string;
    568   Flag: Cardinal;
    569   SaveColor: cardinal;
    570 begin
    571   SaveIndex := SaveDC(DC);
    572   try
    573     bMaxed := IsZoomed(Handle);
    574 
    575     // 扣除客户区域
    576     rFrame := GetFrameSize;
    577     ExcludeClipRect(DC, rFrame.Left, rFrame.Top, FWidth - rFrame.Right, FHeight - rFrame.Bottom);
    578 
    579     ///
    580     ///  标题区域
    581     ///
    582     rCaptionRect := GetCaptionRect(bMaxed);
    583 
    584     // 填充整个窗体背景
    585     hB := CreateSolidBrush(SKINCOLOR_BAKCGROUND);
    586     FillRect(DC, Rect(0, 0, FWidth, FHeight), hB);
    587     DeleteObject(hB);
    588 
    589     /// 绘制窗体图标
    590     rButton := BuildRect(rCaptionRect.Left + 2, rCaptionRect.Top, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
    591     rButton.Top := rButton.Top + (rFrame.Top - rButton.Bottom) div 2;
    592     DrawIconEx(DC, rButton.Left, rButton.Top, GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL);
    593 
    594     rCaptionRect.Left := rButton.Right + 5; // 前部留白
    595 
    596     /// 绘制窗体按钮区域
    597     rButton.Right := rCaptionRect.Right - 1;
    598     rButton.Top := 0;
    599     if bMaxed then
    600       rButton.Top := rCaptionRect.Top;
    601     rButton.Top := rButton.Top + (rFrame.Top - rButton.Top - SIZE_SYSBTN.cy) div 2;
    602     rButton.Left := rButton.Right - SIZE_SYSBTN.cx;
    603     rButton.Bottom := rButton.Top + SIZE_SYSBTN.cy;
    604     DrawButton(Dc, fbkClose, GetBtnState(fbkClose), rButton);
    605 
    606     OffsetRect(rButton, - SIZE_SYSBTN.cx, 0);
    607     if bMaxed then
    608       DrawButton(Dc, fbkRestore, GetBtnState(fbkRestore), rButton)
    609     else
    610       DrawButton(Dc, fbkMax, GetBtnState(fbkMax), rButton);
    611 
    612     OffsetRect(rButton, - SIZE_SYSBTN.cx, 0);
    613     DrawButton(Dc, fbkMin, GetBtnState(fbkMin), rButton);
    614 
    615     rCaptionRect.Right := rButton.Left - 3; // 后部空出
    616 
    617     /// 绘制Caption
    618     sData :=  GetCaption;
    619     SetBkMode(DC, TRANSPARENT);
    620     SaveColor := SetTextColor(DC, $00FFFFFF);
    621 
    622     Flag := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
    623     DrawTextEx(DC, PChar(sData), Length(sData), rCaptionRect, Flag, nil);
    624     SetTextColor(DC, SaveColor);
    625   finally
    626     RestoreDC(DC, SaveIndex);
    627   end;
    628 end;
    629 
    630 procedure TTest.PaintBackground(DC: HDC);
    631 var
    632   hB: HBRUSH;
    633   R: TRect;
    634 begin
    635   GetClientRect(Handle, R);
    636   hB := CreateSolidBrush($00F0F0F0);
    637   FillRect(DC, R, hB);
    638   DeleteObject(hB);
    639 end;
    640 
    641 procedure TTest.Paint(DC: HDC);
    642 begin
    643   // PaintBackground(DC);
    644   // TODO -cMM: TTest.Paint default body inserted
    645 end;
    646 
    647 procedure TTest.WMEraseBkgnd(var message: TWMEraseBkgnd);
    648 var
    649   DC: HDC;
    650   SaveIndex: integer;
    651 begin
    652   DC := Message.DC;
    653   if DC <> 0 then
    654   begin
    655     SaveIndex := SaveDC(DC);
    656     PaintBackground(DC);
    657     RestoreDC(DC, SaveIndex);
    658   end;
    659 
    660   Handled := True;
    661   Message.Result := 1;
    662 end;
    663 
    664 procedure TTest.WMNCActivate(var message: TMessage);
    665 begin
    666   // FFormActive := Message.WParam > 0;
    667   Message.Result := 1;
    668   InvalidateNC;
    669   Handled := True;
    670 end;
    671 
    672 procedure TTest.WMNCCalcSize(var message: TWMNCCalcSize);
    673 var
    674   R: TRect;
    675 begin
    676   // 改变边框尺寸
    677   R := GetFrameSize;
    678   with TWMNCCalcSize(Message).CalcSize_Params^.rgrc[0] do
    679   begin
    680     Inc(Left, R.Left);
    681     Inc(Top, R.Top);
    682     Dec(Right, R.Right);
    683     Dec(Bottom, R.Bottom);
    684   end;
    685   Message.Result := 0;
    686   Handled := True;
    687 end;
    688 
    689 procedure TTest.WMNCHitTest(var Message: TWMNCHitTest);
    690 var
    691   P: TPoint;
    692   iHit: integer;
    693 begin
    694   // 需要把位置转换到实际窗口位置
    695   P := NormalizePoint(Point(Message.XPos, Message.YPos));
    696 
    697   // 获取 位置
    698   iHit := HitTest(p);
    699   if FHotHit > HTNOWHERE then
    700   begin
    701     Message.Result := iHit;
    702     Handled := True;
    703   end;
    704 
    705   if iHit <> FHotHit then
    706   begin
    707     FHotHit := iHit;
    708     InvalidateNC;
    709   end;
    710 
    711 end;
    712 
    713 procedure TTest.WMWindowPosChanging(var message: TWMWindowPosChanging);
    714 var
    715   bChanged: Boolean;
    716 begin
    717   CallDefaultProc(TMessage(Message));
    718 
    719   Handled := True;
    720   bChanged := False;
    721 
    722   /// 防止嵌套
    723   if FChangeSizeCalled then
    724     Exit;
    725 
    726   if (Message.WindowPos^.flags and SWP_NOSIZE = 0) or (Message.WindowPos^.flags and SWP_NOMOVE = 0) then
    727   begin
    728     if (Message.WindowPos^.flags and SWP_NOMOVE = 0) then
    729     begin
    730       FLeft := Message.WindowPos^.x;
    731       FTop := Message.WindowPos^.y;
    732     end;
    733     if (Message.WindowPos^.flags and SWP_NOSIZE = 0) then
    734     begin
    735       bChanged := ((Message.WindowPos^.cx <> FWidth) or (Message.WindowPos^.cy <> FHeight)) and
    736         (Message.WindowPos^.flags and SWP_NOSIZE = 0);
    737       FWidth := Message.WindowPos^.cx;
    738       FHeight := Message.WindowPos^.cy;
    739     end;
    740   end;
    741 
    742   if (Message.WindowPos^.flags and SWP_FRAMECHANGED <> 0) then
    743     bChanged := True;
    744 
    745   if bChanged then
    746   begin
    747     ChangeSize;
    748     InvalidateNC;
    749   end;
    750 end;
    751 
    752 procedure TTest.WMNCLButtonDown(var message: TWMNCHitMessage);
    753 var
    754   iHit: integer;
    755 begin
    756   inherited;
    757 
    758   iHit := HTNOWHERE;
    759   if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or (Message.HitTest = HTMINBUTTON) or
    760     (Message.HitTest = HTHELP) then
    761   begin
    762     iHit := Message.HitTest;
    763 
    764     Message.Result := 0;
    765     Message.Msg := WM_NULL;
    766     Handled := True;
    767   end;
    768 
    769   if iHit <> FPressedHit then
    770   begin
    771     FPressedHit := iHit;
    772     InvalidateNC;
    773   end;
    774 end;
    775 
    776 procedure TTest.WMNCLButtonUp(var Message: TWMNCHitMessage);
    777 var
    778   iWasHit: Integer;
    779 begin
    780   iWasHit := FPressedHit;
    781   if iWasHit <> HTNOWHERE then
    782   begin
    783     FPressedHit := HTNOWHERE;
    784     //InvalidateNC;
    785 
    786     if iWasHit = FHotHit then
    787     begin
    788       case Message.HitTest of
    789         HTCLOSE     : SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0);
    790         HTMAXBUTTON : Maximize;
    791         HTMINBUTTON : Minimize;
    792         HTHELP      : SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0);
    793       end;
    794 
    795       Message.Result := 0;
    796       Message.Msg := WM_NULL;
    797       Handled := True;
    798     end;
    799   end;
    800 end;
    801 
    802 procedure TTest.WMNCMouseMove(var Message: TWMNCMouseMove);
    803 begin
    804   if (FPressedHit <> HTNOWHERE) and (FPressedHit <> Message.HitTest) then
    805     FPressedHit := HTNOWHERE;
    806 end;
    807 
    808 procedure TTest.WMSetText(var Message: TMessage);
    809 begin
    810   CallDefaultProc(Message);
    811   InvalidateNC;
    812   Handled := true;
    813 end;
    814 
    815 procedure TTest.WMNCPaint(var message: TWMNCPaint);
    816 var
    817   DC: HDC;
    818 begin
    819   DC := GetWindowDC(Control.Handle);
    820   PaintNC(DC);
    821   ReleaseDC(Handle, DC);
    822   Handled := True;
    823 end;
    824 
    825 procedure TTest.WMNCUAHDrawCaption(var message: TMessage);
    826 begin
    827   /// 这个消息会在winxp下产生,是内部Bug处理,直接丢弃此消息
    828   Handled := True;
    829 end;
    830 
    831 procedure TTest.WMPaint(var message: TWMPaint);
    832 var
    833   DC, hPaintDC: HDC;
    834   cBuffer: TBitmap;
    835   PS: TPaintStruct;
    836 begin
    837   ///
    838   /// 绘制客户区域
    839   ///
    840   DC := Message.DC;
    841 
    842   hPaintDC := DC;
    843   if DC = 0 then
    844     hPaintDC := BeginPaint(Handle, PS);
    845 
    846   if DC = 0 then
    847   begin
    848     /// 缓冲模式绘制,减少闪烁
    849     cBuffer := TBitmap.Create;
    850     try
    851       cBuffer.SetSize(FWidth, FHeight);
    852       PaintBackground(cBuffer.Canvas.Handle);
    853       Paint(cBuffer.Canvas.Handle);
    854       /// 通知子控件进行绘制
    855       /// 主要是些图形控件的重绘制(如TShape),否则停靠在Form上的图像控件无法正常显示
    856       if Control is TWinControl then
    857         TacWinControl(Control).PaintControls(cBuffer.Canvas.Handle, nil);
    858       BitBlt(hPaintDC, 0, 0, FWidth, FHeight, cBuffer.Canvas.Handle, 0, 0, SRCCOPY);
    859     finally
    860       cBuffer.Free;
    861     end;
    862   end
    863   else
    864   begin
    865     Paint(hPaintDC);
    866     // 通知子控件重绘
    867     if Control is TWinControl then
    868       TacWinControl(Control).PaintControls(hPaintDC, nil);
    869   end;
    870 
    871   if DC = 0 then
    872     EndPaint(Handle, PS);
    873 
    874   Handled := True;
    875 end;
    876 
    877 procedure TTest.WndProc(var message: TMessage);
    878 begin
    879   FHandled := False;
    880   Dispatch(message);
    881 end;
    882 
    883 end.
    完整测试单元代码

    相关API和消息

    • IsZoomed                             --- 窗体是否最大化
    • GetClassInfoEx                      --- 获取窗体图标
    • WM_GETICON                       --- 获取窗体图标
    • DrawTransparentBitmap         --- 绘制透明图片
    • GetWindowLong                     --- 获取窗体信息 
    • DrawIconEx                           --- 绘制ICON
    • SetBkMode                            --- 设置字体绘制背景 
    • SetTextColor                          --- 设置字体绘制颜色

    开发环境:

    • XE3
    • win7

    源代码:

        https://github.com/cmacro/simple/tree/master/TestCaptionToolbar_v0.3

    蘑菇房 (moguf.com)

  • 相关阅读:
    Excel导入导出DataGridView
    博客开通第一天
    windows10 VM12 安装Mac OS X 10.11
    js判断IE浏览器及版本
    C# MD5 加密
    WindowsErrorCode
    localStorage,sessionStorage的使用
    js实现页面锚点定位动画滚动
    纯js实现页面返回顶部的动画
    HTML table固定表头
  • 原文地址:https://www.cnblogs.com/gleam/p/3966841.html
Copyright © 2020-2023  润新知