zoukankan      html  css  js  c++  java
  • 窗体皮肤实现

      前面做的工作就是想在标题区域增加快速工具条。前续的基础工作完成,想要在标题区域增加特殊区域都非常方便。只要在绘制时控制自定义区域需要占用标题区域多少空间,然后直接在所占位置绘制。做这个事情前,稍微把代码规整了下。所以界面皮肤处理放到一个单元中。

    主要处理步骤

      1、划出一个新区域(整个工具条作为一个区域)

      2、处理区域检测(HitTest)

      3、如果是新区域,把相应消息传给这个区域处理。

      4、响应鼠标点击,执行Action

    通过上述步骤就能扩展出所想要的标题区快速工具条的。

    标题按钮区域是作为一个整体处理,这样比较容易控制和扩展。只要当检测区域是标题工具区时,消息交由工具条实现。

     1   HTCUSTOM = 100; //HTHELP + 1;       /// 自定义区域ID
     2   HTCAPTIONTOOLBAR = HTCUSTOM + 1;    /// 标题工具区域ID
     3 
     4 
     5 ///
     6 /// 检测区域时增加自定义区域的检测
     7 function TskForm.HitTest(P: TPoint):integer;
     8 begin
     9     ... ... (代码略)  
    10     ///
    11     ///  标题工具区域
    12     ///    需要前面扣除窗体图标区域
    13     if (Result = HTNOWHERE) and (FToolbar.Visible) then
    14     begin
    15       r.Left := rCaptionRect.Left + 2 + GetSystemMetrics(SM_CXSMICON) + SPALCE_CAPTIONAREA;
    16       R.Top := rCaptionRect.Top + (rCaptionRect.Height - FToolbar.Border.Height) div 2;
    17       R.Right := R.Left + FToolbar.Border.Width;
    18       R.Bottom := R.Top + FToolbar.Border.Height;
    19 
    20       if FToolbar.FOffset.X = -1 then
    21         FToolbar.FOffset := r.TopLeft;
    22 
    23       if PtInRect(r, p) then
    24         Result := HTCAPTIONTOOLBAR;
    25     end;
    26   end;
    27 end;

    这样做的好处就是,简化自定义皮肤TskForm内部的处理。模块化比较清晰,简化实现逻辑。

    标题工具条实现过程

       1、准备绘制的区域

       2、确定绘制区域大小

       3、实现绘制

       4、响应消息

    确定绘制区域大小

      考虑到按钮是动态增加上去,需要根据实际标题区域的按钮数量来确定实际大小。所有的Action存放在记录中,这样每次只要循环Action数组就可以获得相应宽度。

    区域的宽度包括:两条分割线 + 下拉配置菜单 + Button * Count

     1 /// 用于保存Action的信息
     2 TcpToolButton = record
     3   Action: TBasicAction;
     4   Enabled: boolean;
     5   Visible: Boolean;
     6   ImageIndex: Integer;        // 考虑到标题功能图标和实际工具栏功能使用不同图标情况,分开图标索引
     7   Width: Word;                // 实际占用宽度,考虑后续加不同的按钮样式使用
     8   Fade: Word;                 // 褪色量 0 - 255
     9   SaveEvent: TNotifyEvent;    // 原始的Action OnChange事件
    10 end;
    11 
    12 ///
    13 /// 计算实际占用尺寸
    14 function TcpToolbar.CalcSize: TRect;
    15 const
    16   SIZE_SPLITER = 10;
    17   SIZE_POPMENU = 10;
    18   SIZE_BUTTON  = 20;
    19 var
    20   w, h: Integer;
    21   I: Integer;
    22 begin
    23   ///
    24   ///  占用宽度
    25   ///     如果考虑比较复杂的按钮样式和显示标题等功能,那么需要计算每个按钮实际占用宽度才能获得。
    26 
    27   w := SIZE_SPLITER * 2 + SIZE_POPMENU;
    28   for I := 0 to FCount - 1 do
    29     w := w + FItems[i].Width;
    30   h := SIZE_BUTTON;
    31   Result := Rect(0, 0, w, h);
    32 end;

    占用区域大小的问题解决,绘制问题主要考虑在什么位置绘制,怎么获得Action的图标和实际的状态。

    以正常情况考虑绘制区域:从原点(0,0)开始绘制,这样比较符合一般的习惯。只要在绘制前对画布重新设置原点,就能实现。

     1 ///
     2 /// 绘制工具条
     3 if FToolbar.Visible and (rCaptionRect.Right > rCaptionRect.Left) then
     4 begin
     5   /// 防止出现绘制出多余区域,当区域不够时需要进行剪切。
     6   ///  如: 窗体缩小时
     7   CurrentIdx := 0;
     8   bClipRegion := rCaptionRect.Width < FToolbar.Border.Width;
     9   if bClipRegion then
    10   begin
    11     ClipRegion := CreateRectRgnIndirect(rCaptionRect);
    12     CurrentIdx := SelectClipRgn(DC, ClipRegion);
    13     DeleteObject(ClipRegion);
    14   end;
    15 
    16   /// 设置原点偏移量
    17   iLeftOff := rCaptionRect.Left;
    18   iTopOff := rCaptionRect.Top + (rCaptionRect.Height - FToolbar.Border.Height) div 2;
    19   MoveWindowOrg(DC, iLeftOff, iTopOff);
    20   FToolbar.Paint(DC);
    21   MoveWindowOrg(DC, -iLeftOff, -iTopOff);
    22 
    23   if bClipRegion then
    24     SelectClipRgn(DC, CurrentIdx);
    25 
    26   /// 扣除工具条区域
    27   rCaptionRect.Left := rCaptionRect.Left + FToolbar.Border.Width + SPALCE_CAPTIONAREA;
    28 end;

    获取Action的图标

      直接从ImageList中获取。考虑标题区域是纯色,能让标题工具条显的更美观(个人审美),能让工具条支持2中不同的图标。画了一组纯白的图标用于标题区域的显示。

     1 // 创建Bmp,支持透明
     2 // cIcon := TBitmap.Create;
     3 // cIcon.PixelFormat := pf32bit;  // 支持透明
     4 // cIcon.alphaFormat := afIgnored;
     5 
     6 function TcpToolbar.LoadActionIcon(Idx: Integer; AImg: TBitmap):Boolean;
     7 var
     8   bHasImg: Boolean;
     9 begin
    10   /// 获取Action的图标
    11   AImg.Canvas.Brush.Color := clBlack;
    12   AImg.Canvas.FillRect(Rect(0,0, AImg.Width, AImg.Height));
    13   bHasImg := False;
    14   if (FImages <> nil) and (FItems[Idx].ImageIndex >= 0) then
    15     bHasImg := FImages.GetBitmap(FItems[Idx].ImageIndex, AImg);
    16   if not bHasImg and (FItems[Idx].Action is TCustomAction) then
    17     with TCustomAction(FItems[Idx].Action) do
    18       if (Images <> nil) and (ImageIndex >= 0) then
    19         bHasImg := Images.GetBitmap(ImageIndex, AImg);
    20   Result := bHasImg;
    21 end;
    获取Action的图标

    绘制工具条

      有了尺寸和Action就可以直接进行绘制。鼠标滑过和按下状态的处理方法和系统按钮区域的方法一致。

     1 procedure TcpToolbar.Paint(DC: HDC);
     2 
     3   function GetActionState(Idx: Integer): TSkinIndicator;
     4   begin
     5     Result := siInactive;
     6     if (Idx = FPressedIndex) and (FHotIndex = FPressedIndex) then
     7       Result := siPressed
     8     else if Idx = FHotIndex then
     9       Result := siHover;
    10   end;
    11 
    12 var
    13   cIcon: TBitmap;
    14   r: TRect;
    15   I: Integer;
    16   iOpacity: byte;
    17 begin
    18   ///
    19   ///  工具条绘制
    20   ///
    21 
    22   /// 分割线
    23   r := Border;
    24   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    25   SkinData.DrawElement(DC, steSplitter, r);
    26   OffsetRect(r, r.Right - r.Left, 0);
    27 
    28   /// 绘制Button
    29   cIcon := TBitmap.Create;
    30   cIcon.PixelFormat := pf32bit;
    31   cIcon.alphaFormat := afIgnored;
    32   for I := 0 to FCount - 1 do
    33   begin
    34     r.Right := r.Left + FItems[i].Width;
    35     if FItems[I].Enabled then
    36       SkinData.DrawButtonBackground(DC, GetActionState(i), r, FItems[i].Fade);
    37     if LoadActionIcon(i, cIcon) then
    38     begin
    39       iOpacity := 255;
    40       /// 处理不可用状态,图标颜色变暗。
    41       ///   简易处理,增加绘制透明度。
    42       if not FItems[i].Enabled then
    43         iOpacity := 100;
    44 
    45       SkinData.DrawIcon(DC, r, cIcon, iOpacity);
    46     end;
    47     OffsetRect(r, r.Right - r.Left, 0);
    48   end;
    49   cIcon.free;
    50 
    51   /// 分割条
    52   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    53   SkinData.DrawElement(DC, steSplitter, r);
    54   OffsetRect(r, r.Right - r.Left, 0);
    55 
    56   /// 绘制下拉菜单按钮
    57   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    58   SkinData.DrawElement(DC, stePopdown, r);
    59 end;

      

     相应鼠标事件

        对于一个工具条,需要相应的事件有三个鼠标滑过、按下和弹起。滑过是出现Hot效果,按下时处理Button被压下的效果,弹起时执行实际的Action事件。简单处理处理的这三种效果,如果考虑动画效果。那么需要创建一个时钟,设置个背景褪色量(其实是个Alpha透明通道值),然后根据褪色量在时钟消息中进行绘制。时钟最好设置在主皮肤类(TskForm)上,不必为每个区域创建一个句柄,这样可以减少系统资源(句柄)的占用。

        统一消息入口,如果处理了此消息就返回True。这样可以让外部知道是否此消息被处理,以便外部作进一步的响应处理。

     1 function TFormCaptionPlugin.HandleMessage(var Message: TMessage): Boolean;
     2 begin
     3   Result := True;
     4 
     5   case Message.Msg of
     6     WM_NCMOUSEMOVE    : MouseMove(ScreenToClient(TWMNCMouseMove(Message).XCursor, TWMNCMouseMove(Message).YCursor));
     7     WM_NCLBUTTONDOWN  : MouseDown(mbLeft, ScreenToClient(TWMNCLButtonDown(Message).XCursor, TWMNCLButtonDown(Message).YCursor));
     8     WM_NCHITTEST      : HitWindowTest(ScreenToClient(TWMNCHitTest(Message).XPos, TWMNCHitTest(Message).YPos));
     9     WM_NCLBUTTONUP    : MouseUp(mbLeft, ScreenToClient(TWMNCLButtonUp(Message).XCursor, TWMNCLButtonUp(Message).YCursor));
    10 
    11     else
    12       Result := False;
    13   end;
    14 end;

     这里一个比较关键的是,鼠标在这个区域内的实际位置。一般窗体都会有Handle,所以能直接通过API转换鼠标位置。

    区域需要依靠主窗口的位置才能获得。每次窗口在处理尺寸时,区域的偏移位置是可以获得的。像标题工具条这种左靠齐,其实这个偏移位置算好后就肯定是不会变的。

    1 // 偏移量
    2 //   = 有效标题区域 - 系统图标位置 - 区域间隙
    3 r.Left := rCaptionRect.Left + 2 + GetSystemMetrics(SM_CXSMICON) + SPALCE_CAPTIONAREA;
    4 r.Top := rCaptionRect.Top + (rCaptionRect.Height - FToolbar.Border.Height) div 2;
     1 function TFormCaptionPlugin.ScreenToClient(x, y: Integer): TPoint;
     2 var
     3   P: TPoint;
     4 begin
     5   /// 调整位置
     6   ///    以 FOffset 为中心位置
     7   P := FOwner.NormalizePoint(Point(x, Y));
     8   p.X := p.X - FOffset.X;
     9   p.Y := p.y - FOffset.Y;
    10 
    11   Result := p;
    12 end;

     上面鼠标的消息最终通过HitTest获取,实际鼠标所在按钮位置。这个处理方法和外部的TskForm处理方法一致,检测位置设置状态参数然后再重绘。

    如:鼠标滑过时的消息处理。

     1 procedure TcpToolbar.MouseMove(p: TPoint);
     2 var
     3   iIdx: Integer;
     4 begin
     5   /// 鼠标滑入时设置HotIndex值
     6   iIdx := HitTest(p);
     7   if iIdx <> FHotIndex then
     8   begin
     9     FHotIndex := iIdx;
    10     Invalidate;
    11   end;
    12 end;
     1 function TcpToolbar.HitTest(P: TPoint): integer;
     2 var
     3   iOff: Integer;
     4   iIdx: integer;
     5   I: Integer;
     6 begin
     7   ///
     8   ///  检测鼠标位置
     9   ///    鼠标位置的 FCount位 为工具条系统菜单位置。
    10   iIdx := -1;
    11   iOff := RES_CAPTIONTOOLBAR.w;
    12   if p.x > iOff then
    13   begin
    14     for I := 0 to FCount - 1 do
    15     begin
    16       if p.X < iOff then
    17         Break;
    18 
    19       iIdx := i;
    20       inc(iOff, FItems[i].Width);
    21     end;
    22 
    23     if p.x > iOff then
    24     begin
    25       iIdx := -1;
    26       inc(iOff, RES_CAPTIONTOOLBAR.w);
    27       if p.x > iOff then
    28         iIdx := FCount;  // FCount 为系统菜单按钮
    29     end;
    30   end;
    31 
    32   Result := iIdx;
    33 end;
    坐标所在按钮区域检测 HitTest

    还有些细节方面的处理,如鼠标离开这个区域时的处理。这样整个工具区的基本处理完成,整个工具条区域的处理还是相对比较简单。

    Action状态处理

      Action处理主要是考虑,当外部改变Action状态。如:无效,不可见的一些事件处理。标准的处理方法是在关联Action是创建一个ActionLink实现联动,由于TskForm没有从TControl继承,没法使用此方法进行处理。在TBasicAction改变状态时会触发一个OnChange的保护(protected)事件,可以直接把事件挂接上去,就能简单处理状态。

    保护方法的访问:创建一个访问类,进行引用。

    1 type
    2   TacWinControl = class(TWinControl);
    3   TacAction = class(TBasicAction);
    1   ZeroMemory(@FItems[FCount], SizeOf(TcpToolButton));
    2   FItems[FCount].Action := Action;
    3   FItems[FCount].Enabled := true;       // <--- 这里应该获取Actoin的当前状态,这里简略处理。
    4   FItems[FCount].Visible := True;       // <--- 同上,注:现有代码中并未处理此状态
    5   FItems[FCount].ImageIndex := AImageIndex;
    6   FItems[FCount].Width := 20;
    7   FItems[FCount].Fade  := 255;
    8   FItems[FCount].SaveEvent := TacAction(Action).OnChange;  // 保存原事件
    9   TacAction(Action).OnChange := DoOnActionChange;          // 挂接事件

     注意:不要把原事件丢了,需要保存。防止外部有挂接的情况下出现外部无法。

    根据状态的不同,直接修改记录的Enabled 和 Visible 这两个状态。绘制时可以直接使用。

     1 procedure TcpToolbar.DoOnActionChange(Sender: TObject);
     2 var
     3   idx: Integer;
     4   bResize: Boolean;
     5 begin
     6   if Sender is TBasicAction then
     7   begin
     8     idx := IndexOf(TBasicAction(Sender));
     9     if (idx >= 0) and (idx < FCount) then
    10     begin
    11       ///
    12       ///  外部状态改变响应
    13       ///
    14       if FItems[idx].Action.InheritsFrom(TContainedAction) then
    15       begin
    16         FItems[idx].Enabled := TContainedAction(Sender).Enabled;
    17         bResize := FItems[idx].Visible <> TContainedAction(Sender).Visible;
    18         if bResize then
    19         begin
    20           FItems[idx].Visible := not FItems[idx].Visible;
    21           Update
    22         end
    23         else
    24           Invalidate;
    25       end;
    26 
    27       /// 执行原有事件
    28       if Assigned(FItems[idx].SaveEvent) then
    29         FItems[idx].SaveEvent(Sender);
    30     end;
    31   end;
    32 end;

     在绘制时就可以通过记录中的状态和鼠标位置状态进行判断,来绘制出所需要的效果

     1   ... ...
     2   // 如果按钮有效,那么进行按钮底色绘制。
     3   if FItems[I].Enabled then
     4     SkinData.DrawButtonBackground(DC, GetActionState(i), r, FItems[i].Fade);
     5   if LoadActionIcon(i, cIcon) then
     6   begin
     7     /// 处理不可用状态,图标颜色变暗。
     8     ///   简易处理,增加绘制透明度。
     9     iOpacity := 255;
    10     if not FItems[i].Enabled then
    11       iOpacity := 100;
    12 
    13     SkinData.DrawIcon(DC, r, cIcon, iOpacity);
    14   end;
    15   ... ...
    16 
    17   // 获取Action底色的显示状态
    18   //  按下状态、滑过状态、默认状态
    19   function GetActionState(Idx: Integer): TSkinIndicator;
    20   begin
    21     Result := siInactive;
    22     if (Idx = FPressedIndex) and (FHotIndex = FPressedIndex) then
    23       Result := siPressed
    24     else if Idx = FHotIndex then
    25       Result := siHover;
    26   end;
    27   

    在窗体上加入测试Action

    1 procedure TForm11.FormCreate(Sender: TObject);
    2 begin
    3   FTest.Toolbar.Images := ImageList2;
    4   FTest.Toolbar.Add(Action1, 0);
    5   FTest.Toolbar.Add(Action2, 1);
    6   FTest.Toolbar.Add(Action3, 2);
    7 end;

     

     完成~~

       最终效果,就是上面的GIF效果。想做的更好,那么就需要在细节上考虑。细节是最花时间的地方。

    单元代码

       1 unit uFormSkins;
       2 
       3 interface
       4 
       5 uses
       6   Classes, windows, Controls, Graphics, Forms, messages, pngimage, Types, ImgList, Actions, ActnList;
       7 
       8 const
       9   WM_NCUAHDRAWCAPTION = $00AE;
      10 
      11   CKM_ADD             = WM_USER + 1;  // 增加标题区域位置
      12 
      13   HTCUSTOM = 100; //HTHELP + 1;              /// 自定义区域ID
      14   HTCAPTIONTOOLBAR = HTCUSTOM + 1;    /// 标题工具区域
      15 
      16 type
      17   TskForm = class;
      18 
      19   TFormButtonKind = (fbkMin, fbkMax, fbkRestore, fbkClose, fbkHelp);
      20   TSkinIndicator = (siInactive, siHover, siPressed, siSelected, siHoverSelected);
      21 
      22   TFormCaptionPlugin = class
      23   private
      24     FOffset: TPoint;  // 实际标题区域所在的偏移位置
      25     FBorder: TRect;
      26     FOwner: TskForm;
      27     FVisible: Boolean;
      28 
      29   protected
      30     procedure Paint(DC: HDC); virtual; abstract;
      31     function  CalcSize: TRect; virtual; abstract;
      32     function  ScreenToClient(x, y: Integer): TPoint;
      33 
      34     function  HandleMessage(var Message: TMessage): Boolean; virtual;
      35 
      36     procedure HitWindowTest(P: TPoint); virtual;
      37     procedure MouseMove(p: TPoint); virtual;
      38     procedure MouseDown(Button: TMouseButton; p: TPoint); virtual;
      39     procedure MouseUp(Button: TMouseButton; p: TPoint); virtual;
      40     procedure MouseLeave; virtual;
      41 
      42     procedure Invalidate;
      43     procedure Update;
      44   public
      45     constructor Create(AOwner: TskForm); virtual;
      46 
      47     property Border: TRect read FBorder;
      48     property Visible: Boolean read FVisible;
      49   end;
      50 
      51   TcpToolButton = record
      52     Action: TBasicAction;
      53     Enabled: boolean;
      54     Visible: Boolean;
      55     ImageIndex: Integer;        // 考虑到标题功能图标和实际工具栏功能使用不同图标情况,分开图标索引
      56     Width: Word;                // 实际占用宽度,考虑后续加不同的按钮样式使用
      57     Fade: Word;                 // 褪色量 0 - 255
      58     SaveEvent: TNotifyEvent;    // 原始的Action OnChange事件
      59   end;
      60 
      61   TcpToolbar = class(TFormCaptionPlugin)
      62   private
      63     FItems: array of TcpToolButton;
      64     FCount: Integer;
      65     FHotIndex: Integer;
      66 
      67     // 考虑标题栏比较特殊,背景使用的是纯属情况。图标需要做的更符合纯属需求。
      68     FImages: TCustomImageList;
      69     FPressedIndex: Integer;
      70 
      71     procedure ExecAction(Index: Integer);
      72     procedure PopConfigMenu;
      73     function  HitTest(P: TPoint): integer;
      74     function  LoadActionIcon(Idx: Integer; AImg: TBitmap):Boolean;
      75     procedure SetImages(const Value: TCustomImageList);
      76     procedure DoOnActionChange(Sender: TObject);
      77   protected
      78     // 绘制按钮样式
      79     procedure Paint(DC: HDC); override;
      80     // 计算实际占用尺寸
      81     function  CalcSize: TRect; override;
      82 
      83     procedure HitWindowTest(P: TPoint); override;
      84     procedure MouseMove(p: TPoint); override;
      85     procedure MouseDown(Button: TMouseButton; p: TPoint); override;
      86     procedure MouseUp(Button: TMouseButton; p: TPoint); override;
      87     procedure MouseLeave; override;
      88 
      89   public
      90     constructor Create(AOwner: TskForm); override;
      91 
      92     procedure Add(Action: TBasicAction; AImageIndex: Integer = -1);
      93     procedure Delete(Index: Integer);
      94     function  IndexOf(Action: TBasicAction): Integer;
      95 
      96     property Images: TCustomImageList read FImages write SetImages;
      97   end;
      98 
      99 
     100   TskForm = class
     101   private
     102     FCallDefaultProc: Boolean;
     103     FChangeSizeCalled: Boolean;
     104     FControl: TWinControl;
     105     FHandled: Boolean;
     106 
     107     FRegion: HRGN;
     108     FLeft: integer;
     109     FTop: integer;
     110     FWidth: integer;
     111     FHeight: integer;
     112 
     113     /// 窗体图标
     114     FIcon: TIcon;
     115     FIconHandle: HICON;
     116 
     117     // 鼠标位置状态,只处理监控的位置,其他有交由系统处理
     118     FPressedHit: Integer;     // 实际按下的位置
     119     FHotHit: integer;         // 记录上次的测试位置
     120 
     121     FToolbar: TcpToolbar;
     122 
     123     function GetHandle: HWND; inline;
     124     function GetForm: TCustomForm; inline;
     125     function GetFrameSize: TRect;
     126     function GetCaptionRect(AMaxed: Boolean): TRect; inline;
     127     function GetCaption: string;
     128     function GetIcon: TIcon;
     129     function GetIconFast: TIcon;
     130 
     131     procedure ChangeSize;
     132     function  NormalizePoint(P: TPoint): TPoint;
     133     function  HitTest(P: TPoint):integer;
     134     procedure Maximize;
     135     procedure Minimize;
     136 
     137     // 第一组 实现绘制基础
     138     procedure WMNCPaint(var message: TWMNCPaint); message WM_NCPAINT;
     139     procedure WMNCActivate(var message: TMessage); message WM_NCACTIVATE;
     140     procedure WMNCLButtonDown(var message: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
     141     procedure WMNCUAHDrawCaption(var message: TMessage); message WM_NCUAHDRAWCAPTION;
     142 
     143     // 第二组 控制窗体样式
     144     procedure WMNCCalcSize(var message: TWMNCCalcSize); message WM_NCCALCSIZE;
     145     procedure WMWindowPosChanging(var message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
     146 
     147     // 第三组 绘制背景和内部控件
     148     procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
     149     procedure WMPaint(var message: TWMPaint); message WM_PAINT;
     150 
     151     // 第四组 控制按钮状态
     152     procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
     153     procedure WMNCLButtonUp(var Message: TWMNCLButtonUp); message WM_NCLBUTTONUP;
     154     procedure WMNCMouseMove(var Message: TWMNCMouseMove); message WM_NCMOUSEMOVE;
     155     procedure WMSetText(var Message: TMessage); message WM_SETTEXT;
     156 
     157 
     158     procedure WndProc(var message: TMessage);
     159 
     160     procedure CallDefaultProc(var message: TMessage);
     161   protected
     162     property  Handle: HWND read GetHandle;
     163     procedure InvalidateNC;
     164     procedure PaintNC(DC: HDC);
     165     procedure PaintBackground(DC: HDC);
     166     procedure Paint(DC: HDC);
     167 
     168   public
     169     constructor Create(AOwner: TWinControl);
     170     destructor Destroy; override;
     171 
     172     function DoHandleMessage(var message: TMessage): Boolean;
     173 
     174     property Toolbar: TcpToolbar read FToolbar;
     175     property Handled: Boolean read FHandled write FHandled;
     176     property Control: TWinControl read FControl;
     177     property Form: TCustomForm read GetForm;
     178   end;
     179 
     180 
     181 implementation
     182 
     183 const
     184   SPALCE_CAPTIONAREA = 3;
     185 
     186 {$R MySkin.RES}
     187 
     188 type
     189   TacWinControl = class(TWinControl);
     190   TacAction = class(TBasicAction);
     191 
     192   Res = class
     193     class procedure LoadGraphic(const AName: string; AGraphic: TGraphic);
     194     class procedure LoadBitmap(const AName: string; AGraphic: TBitmap);
     195   end;
     196 
     197   TResArea = record
     198     x: Integer;
     199     y: Integer;
     200     w: Integer;
     201     h: Integer;
     202   end;
     203 
     204   TSkinToolbarElement = (steSplitter, stePopdown);
     205 
     206   SkinData = class
     207   private
     208   class var
     209     FData: TBitmap;
     210 
     211   public
     212     class constructor Create;
     213     class destructor Destroy;
     214 
     215     class procedure DrawButtonBackground(DC: HDC; AState: TSkinIndicator; const R: TRect; const Opacity: Byte = 255); static;
     216     class procedure DrawButton(DC: HDC; AKind: TFormButtonKind; AState: TSkinIndicator; const R: TRect); static;
     217     class procedure DrawElement(DC: HDC; AItem: TSkinToolbarElement; const R: TRect);
     218     class procedure DrawIcon(DC: HDC; R: TRect; ASrc: TBitmap; const Opacity: Byte = 255);
     219   end;
     220 
     221 const
     222   SKINCOLOR_BAKCGROUND  = $00BF7B18;  // 背景色
     223   SKINCOLOR_BTNHOT      = $00F2D5C2;  // Hot 激活状态
     224   SKINCOLOR_BTNPRESSED  = $00E3BDA3;  // 按下状态
     225   SIZE_SYSBTN: TSize    = (cx: 29; cy: 18);
     226   SIZE_FRAME: TRect     = (Left: 4; Top: 29; Right: 5; Bottom: 5); // 窗体边框的尺寸
     227   SPACE_AREA            = 3;          // 功能区域之间间隔
     228   SIZE_RESICON          = 16;         // 资源中图标默认尺寸
     229   SIZE_HEIGHTTOOLBAR    = 16;
     230 
     231   RES_CAPTIONTOOLBAR: TResArea = (x: 0; y: 16; w: 9; h: 16);
     232 
     233 
     234 function BuildRect(L, T, W, H: Integer): TRect; inline;
     235 begin
     236   Result := Rect(L, T, L + W, T + H);
     237 end;
     238 
     239 procedure DrawTransparentBitmap(Source: TBitmap; sx, sy: Integer; Destination: HDC;
     240   const dX, dY: Integer;  w, h: Integer; const Opacity: Byte = 255); overload;
     241 var
     242   BlendFunc: TBlendFunction;
     243 begin
     244   BlendFunc.BlendOp := AC_SRC_OVER;
     245   BlendFunc.BlendFlags := 0;
     246   BlendFunc.SourceConstantAlpha := Opacity;
     247 
     248   if Source.PixelFormat = pf32bit then
     249     BlendFunc.AlphaFormat := AC_SRC_ALPHA
     250   else
     251     BlendFunc.AlphaFormat := 0;
     252 
     253   AlphaBlend(Destination, dX, dY, w, h, Source.Canvas.Handle, sx, sy, w, h, BlendFunc);
     254 end;
     255 
     256 
     257 procedure TskForm.CallDefaultProc(var message: TMessage);
     258 begin
     259   if FCallDefaultProc then
     260     FControl.WindowProc(message)
     261   else
     262   begin
     263     FCallDefaultProc := True;
     264     FControl.WindowProc(message);
     265     FCallDefaultProc := False;
     266   end;
     267 end;
     268 
     269 procedure TskForm.ChangeSize;
     270 var
     271   hTmp: HRGN;
     272 begin
     273   /// 设置窗体外框样式
     274   FChangeSizeCalled := True;
     275   try
     276     hTmp := FRegion;
     277     try
     278       /// 创建矩形外框,3的倒角
     279       FRegion := CreateRoundRectRgn(0, 0, FWidth, FHeight, 3, 3);
     280       SetWindowRgn(Handle, FRegion, True);
     281     finally
     282       if hTmp <> 0 then
     283         DeleteObject(hTmp);
     284     end;
     285   finally
     286     FChangeSizeCalled := False;
     287   end;
     288 end;
     289 
     290 function TskForm.NormalizePoint(P: TPoint): TPoint;
     291 var
     292   rWindowPos, rClientPos: TPoint;
     293 begin
     294   rWindowPos := Point(FLeft, FTop);
     295   rClientPos := Point(0, 0);
     296   ClientToScreen(Handle, rClientPos);
     297   Result := P;
     298   ScreenToClient(Handle, Result);
     299   Inc(Result.X, rClientPos.X - rWindowPos.X);
     300   Inc(Result.Y, rClientPos.Y - rWindowPos.Y);
     301 end;
     302 
     303 function TskForm.HitTest(P: TPoint):integer;
     304 var
     305   bMaxed: Boolean;
     306   r: TRect;
     307   rCaptionRect: TRect;
     308   rFrame: TRect;
     309 begin
     310   Result := HTNOWHERE;
     311 
     312   ///
     313   /// 检测位置
     314   ///
     315   rFrame := GetFrameSize;
     316   if p.Y > rFrame.Top then
     317     Exit;
     318 
     319   ///
     320   ///  只关心窗体按钮区域
     321   ///
     322   bMaxed := IsZoomed(Handle);
     323   rCaptionRect := GetCaptionRect(bMaxed);
     324   if PtInRect(rCaptionRect, p) then
     325   begin
     326     r.Right := rCaptionRect.Right - 1;
     327     r.Top := 0;
     328     if bMaxed then
     329       r.Top := rCaptionRect.Top;
     330     r.Top := r.Top + (rFrame.Top - r.Top - SIZE_SYSBTN.cy) div 2;
     331     r.Left := r.Right - SIZE_SYSBTN.cx;
     332     r.Bottom := r.Top + SIZE_SYSBTN.cy;
     333 
     334     ///
     335     /// 实际绘制的按钮就三个,其他没处理
     336     ///
     337     if (P.Y >= r.Top) and (p.Y <= r.Bottom) and (p.X <= r.Right) then
     338     begin
     339       if (P.X >= r.Left) then
     340         Result := HTCLOSE
     341       else if p.X >= (r.Left - SIZE_SYSBTN.cx) then
     342         Result := HTMAXBUTTON
     343       else if p.X >= (r.Left - SIZE_SYSBTN.cx * 2) then
     344         Result := HTMINBUTTON;
     345     end;
     346 
     347     ///
     348     ///  标题工具区域
     349     ///    需要前面扣除窗体图标区域
     350     if (Result = HTNOWHERE) and (FToolbar.Visible) then
     351     begin
     352       r.Left := rCaptionRect.Left + 2 + GetSystemMetrics(SM_CXSMICON) + SPALCE_CAPTIONAREA;
     353       R.Top := rCaptionRect.Top + (rCaptionRect.Height - FToolbar.Border.Height) div 2;
     354       R.Right := R.Left + FToolbar.Border.Width;
     355       R.Bottom := R.Top + FToolbar.Border.Height;
     356 
     357       if FToolbar.FOffset.X = -1 then
     358         FToolbar.FOffset := r.TopLeft;
     359 
     360       if PtInRect(r, p) then
     361         Result := HTCAPTIONTOOLBAR;
     362     end;
     363   end;
     364 end;
     365 
     366 constructor TskForm.Create(AOwner: TWinControl);
     367 begin
     368   FControl := AOwner;
     369   FRegion := 0;
     370   FChangeSizeCalled := False;
     371   FCallDefaultProc := False;
     372 
     373   FWidth := FControl.Width;
     374   FHeight := FControl.Height;
     375   FIcon := nil;
     376   FIconHandle := 0;
     377 
     378   FToolbar := TcpToolbar.Create(Self);
     379 end;
     380 
     381 destructor TskForm.Destroy;
     382 begin
     383   FToolbar.Free;
     384 
     385   FIconHandle := 0;
     386   if FIcon <> nil then      FIcon.Free;
     387   if FRegion <> 0 then      DeleteObject(FRegion);
     388   inherited;
     389 end;
     390 
     391 function TskForm.DoHandleMessage(var message: TMessage): Boolean;
     392 begin
     393   Result := False;
     394   if not FCallDefaultProc then
     395   begin
     396     FHandled := False;
     397     WndProc(message);
     398     Result := Handled;
     399   end;
     400 end;
     401 
     402 function TskForm.GetFrameSize: TRect;
     403 begin
     404   Result := SIZE_FRAME;
     405 end;
     406 
     407 function TskForm.GetCaptionRect(AMaxed: Boolean): TRect;
     408 var
     409   rFrame: TRect;
     410 begin
     411   rFrame := GetFrameSize;
     412   // 最大化状态简易处理
     413   if AMaxed then
     414     Result := Rect(8, 8, FWidth - 9 , rFrame.Top)
     415   else
     416     Result := Rect(rFrame.Left, 3, FWidth - rFrame.right, rFrame.Top);
     417 end;
     418 
     419 function TskForm.GetCaption: string;
     420 var
     421   Buffer: array [0..255] of Char;
     422   iLen: integer;
     423 begin
     424   if Handle <> 0 then
     425   begin
     426     iLen := GetWindowText(Handle, Buffer, Length(Buffer));
     427     SetString(Result, Buffer, iLen);
     428   end
     429   else
     430     Result := '';
     431 end;
     432 
     433 function TskForm.GetForm: TCustomForm;
     434 begin
     435   Result := TCustomForm(Control);
     436 end;
     437 
     438 function TskForm.GetHandle: HWND;
     439 begin
     440   if FControl.HandleAllocated then
     441     Result := FControl.Handle
     442   else
     443     Result := 0;
     444 end;
     445 
     446 function TskForm.GetIcon: TIcon;
     447 var
     448   IconX, IconY: integer;
     449   TmpHandle: THandle;
     450   Info: TWndClassEx;
     451   Buffer: array [0 .. 255] of Char;
     452 begin
     453   ///
     454   /// 获取当前form的图标
     455   /// 这个图标和App的图标是不同的
     456   ///
     457   TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_SMALL, 0));
     458   if TmpHandle = 0 then
     459     TmpHandle := THandle(SendMessage(Handle, WM_GETICON, ICON_BIG, 0));
     460 
     461   if TmpHandle = 0 then
     462   begin
     463     { Get instance }
     464     GetClassName(Handle, @Buffer, SizeOf(Buffer));
     465     FillChar(Info, SizeOf(Info), 0);
     466     Info.cbSize := SizeOf(Info);
     467 
     468     if GetClassInfoEx(GetWindowLong(Handle, GWL_HINSTANCE), @Buffer, Info) then
     469     begin
     470       TmpHandle := Info.hIconSm;
     471       if TmpHandle = 0 then
     472         TmpHandle := Info.HICON;
     473     end
     474   end;
     475 
     476   if FIcon = nil then
     477     FIcon := TIcon.Create;
     478 
     479   if TmpHandle <> 0 then
     480   begin
     481     IconX := GetSystemMetrics(SM_CXSMICON);
     482     if IconX = 0 then
     483       IconX := GetSystemMetrics(SM_CXSIZE);
     484     IconY := GetSystemMetrics(SM_CYSMICON);
     485     if IconY = 0 then
     486       IconY := GetSystemMetrics(SM_CYSIZE);
     487     FIcon.Handle := CopyImage(TmpHandle, IMAGE_ICON, IconX, IconY, 0);
     488     FIconHandle := TmpHandle;
     489   end;
     490 
     491   Result := FIcon;
     492 end;
     493 
     494 function TskForm.GetIconFast: TIcon;
     495 begin
     496   if (FIcon = nil) or (FIconHandle = 0) then
     497     Result := GetIcon
     498   else
     499     Result := FIcon;
     500 end;
     501 
     502 procedure TskForm.InvalidateNC;
     503 begin
     504   if FControl.HandleAllocated then
     505     SendMessage(Handle, WM_NCPAINT, 1, 0);
     506 end;
     507 
     508 procedure TskForm.Maximize;
     509 begin
     510   if Handle <> 0 then
     511   begin
     512     FPressedHit := 0;
     513     FHotHit := 0;
     514     if IsZoomed(Handle) then
     515       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
     516     else
     517       SendMessage(Handle, WM_SYSCOMMAND, SC_MAXIMIZE, 0);
     518   end;
     519 end;
     520 
     521 procedure TskForm.Minimize;
     522 begin
     523   if Handle <> 0 then
     524   begin
     525     FPressedHit := 0;
     526     FHotHit := 0;
     527     if IsIconic(Handle) then
     528       SendMessage(Handle, WM_SYSCOMMAND, SC_RESTORE, 0)
     529     else
     530       SendMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
     531    end;
     532 end;
     533 
     534 procedure TskForm.PaintNC(DC: HDC);
     535 const
     536   HITVALUES: array [TFormButtonKind] of integer = (HTMINBUTTON, HTMAXBUTTON, HTMAXBUTTON, HTCLOSE, HTHELP);
     537 
     538   function GetBtnState(AKind: TFormButtonKind): TSkinIndicator;
     539   begin
     540     if (FPressedHit = FHotHit) and (FPressedHit = HITVALUES[AKind]) then
     541       Result := siPressed
     542     else if FHotHit = HITVALUES[AKind] then
     543       Result := siHover
     544     else
     545       Result := siInactive;
     546   end;
     547 
     548 var
     549   bClipRegion: boolean;
     550   hB: HBRUSH;
     551   rFrame: TRect;
     552   rButton: TRect;
     553   SaveIndex: integer;
     554   bMaxed: Boolean;
     555   ClipRegion: HRGN;
     556   CurrentIdx: Integer;
     557   rCaptionRect : TRect;
     558   sData: string;
     559   Flag: Cardinal;
     560   iLeftOff: Integer;
     561   iTopOff: Integer;
     562   SaveColor: cardinal;
     563 begin
     564   SaveIndex := SaveDC(DC);
     565   try
     566     bMaxed := IsZoomed(Handle);
     567 
     568     // 扣除客户区域
     569     rFrame := GetFrameSize;
     570     ExcludeClipRect(DC, rFrame.Left, rFrame.Top, FWidth - rFrame.Right, FHeight - rFrame.Bottom);
     571 
     572     ///
     573     ///  标题区域
     574     ///
     575     rCaptionRect := GetCaptionRect(bMaxed);
     576 
     577     // 填充整个窗体背景
     578     hB := CreateSolidBrush(SKINCOLOR_BAKCGROUND);
     579     FillRect(DC, Rect(0, 0, FWidth, FHeight), hB);
     580     DeleteObject(hB);
     581 
     582     ///
     583     /// 绘制窗体图标
     584     rButton := BuildRect(rCaptionRect.Left + 2, rCaptionRect.Top, GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON));
     585     rButton.Top := rButton.Top + (rFrame.Top - rButton.Bottom) div 2;
     586     DrawIconEx(DC, rButton.Left, rButton.Top, GetIconFast.Handle, 0, 0, 0, 0, DI_NORMAL);
     587     rCaptionRect.Left := rButton.Right + SPALCE_CAPTIONAREA; //
     588 
     589     ///
     590     /// 绘制窗体按钮区域
     591     rButton.Right := rCaptionRect.Right - 1;
     592     rButton.Top := 0;
     593     if bMaxed then
     594       rButton.Top := rCaptionRect.Top;
     595     rButton.Top := rButton.Top + (rFrame.Top - rButton.Top - SIZE_SYSBTN.cy) div 2;
     596     rButton.Left := rButton.Right - SIZE_SYSBTN.cx;
     597     rButton.Bottom := rButton.Top + SIZE_SYSBTN.cy;
     598     SkinData.DrawButton(Dc, fbkClose, GetBtnState(fbkClose), rButton);
     599 
     600     OffsetRect(rButton, - SIZE_SYSBTN.cx, 0);
     601     if bMaxed then
     602       SkinData.DrawButton(Dc, fbkRestore, GetBtnState(fbkRestore), rButton)
     603     else
     604       SkinData.DrawButton(Dc, fbkMax, GetBtnState(fbkMax), rButton);
     605 
     606     OffsetRect(rButton, - SIZE_SYSBTN.cx, 0);
     607     SkinData.DrawButton(Dc, fbkMin, GetBtnState(fbkMin), rButton);
     608     rCaptionRect.Right := rButton.Left - SPALCE_CAPTIONAREA; // 后部空出
     609 
     610     ///
     611     /// 绘制工具条
     612     if FToolbar.Visible and (rCaptionRect.Right > rCaptionRect.Left) then
     613     begin
     614       /// 防止出现绘制出多余区域,当区域不够时需要进行剪切。
     615       ///  如: 窗体缩小时
     616       CurrentIdx := 0;
     617       bClipRegion := rCaptionRect.Width < FToolbar.Border.Width;
     618       if bClipRegion then
     619       begin
     620         ClipRegion := CreateRectRgnIndirect(rCaptionRect);
     621         CurrentIdx := SelectClipRgn(DC, ClipRegion);
     622         DeleteObject(ClipRegion);
     623       end;
     624 
     625       iLeftOff := rCaptionRect.Left;
     626       iTopOff := rCaptionRect.Top + (rCaptionRect.Height - FToolbar.Border.Height) div 2;
     627       MoveWindowOrg(DC, iLeftOff, iTopOff);
     628       FToolbar.Paint(DC);
     629       MoveWindowOrg(DC, -iLeftOff, -iTopOff);
     630 
     631       if bClipRegion then
     632         SelectClipRgn(DC, CurrentIdx);
     633 
     634       /// 扣除工具条区域
     635       rCaptionRect.Left := rCaptionRect.Left + FToolbar.Border.Width + SPALCE_CAPTIONAREA;
     636     end;
     637 
     638     ///
     639     /// 绘制Caption
     640     if rCaptionRect.Right > rCaptionRect.Left then
     641     begin
     642       sData :=  GetCaption;
     643       SetBkMode(DC, TRANSPARENT);
     644       SaveColor := SetTextColor(DC, $00FFFFFF);
     645 
     646       Flag := DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
     647       DrawTextEx(DC, PChar(sData), Length(sData), rCaptionRect, Flag, nil);
     648       SetTextColor(DC, SaveColor);
     649     end;
     650   finally
     651     RestoreDC(DC, SaveIndex);
     652   end;
     653 end;
     654 
     655 procedure TskForm.PaintBackground(DC: HDC);
     656 var
     657   hB: HBRUSH;
     658   R: TRect;
     659 begin
     660   GetClientRect(Handle, R);
     661   hB := CreateSolidBrush($00F0F0F0);
     662   FillRect(DC, R, hB);
     663   DeleteObject(hB);
     664 end;
     665 
     666 procedure TskForm.Paint(DC: HDC);
     667 begin
     668   // PaintBackground(DC);
     669   // TODO -cMM: TskForm.Paint default body inserted
     670 end;
     671 
     672 procedure TskForm.WMEraseBkgnd(var message: TWMEraseBkgnd);
     673 var
     674   DC: HDC;
     675   SaveIndex: integer;
     676 begin
     677   DC := Message.DC;
     678   if DC <> 0 then
     679   begin
     680     SaveIndex := SaveDC(DC);
     681     PaintBackground(DC);
     682     RestoreDC(DC, SaveIndex);
     683   end;
     684 
     685   Handled := True;
     686   Message.Result := 1;
     687 end;
     688 
     689 procedure TskForm.WMNCActivate(var message: TMessage);
     690 begin
     691   // FFormActive := Message.WParam > 0;
     692   Message.Result := 1;
     693   InvalidateNC;
     694   Handled := True;
     695 end;
     696 
     697 procedure TskForm.WMNCCalcSize(var message: TWMNCCalcSize);
     698 var
     699   R: TRect;
     700 begin
     701   // 改变边框尺寸
     702   R := GetFrameSize;
     703   with TWMNCCalcSize(Message).CalcSize_Params^.rgrc[0] do
     704   begin
     705     Inc(Left, R.Left);
     706     Inc(Top, R.Top);
     707     Dec(Right, R.Right);
     708     Dec(Bottom, R.Bottom);
     709   end;
     710   Message.Result := 0;
     711   Handled := True;
     712 end;
     713 
     714 procedure TskForm.WMNCHitTest(var Message: TWMNCHitTest);
     715 var
     716   P: TPoint;
     717   iHit: integer;
     718 begin
     719   // 需要把位置转换到实际窗口位置
     720   P := NormalizePoint(Point(Message.XPos, Message.YPos));
     721 
     722   // 获取 位置
     723   iHit := HitTest(p);
     724   if FHotHit > HTNOWHERE then
     725   begin
     726     Message.Result := iHit;
     727     Handled := True;
     728   end;
     729 
     730   if iHit <> FHotHit then
     731   begin
     732     if FHotHit = HTCAPTIONTOOLBAR then
     733       FToolbar.MouseLeave;
     734 
     735     FHotHit := iHit;
     736     InvalidateNC;
     737   end;
     738 
     739 end;
     740 
     741 procedure TskForm.WMWindowPosChanging(var message: TWMWindowPosChanging);
     742 var
     743   bChanged: Boolean;
     744 begin
     745   CallDefaultProc(TMessage(Message));
     746 
     747   Handled := True;
     748   bChanged := False;
     749 
     750   /// 防止嵌套
     751   if FChangeSizeCalled then
     752     Exit;
     753 
     754   if (Message.WindowPos^.flags and SWP_NOSIZE = 0) or (Message.WindowPos^.flags and SWP_NOMOVE = 0) then
     755   begin
     756     if (Message.WindowPos^.flags and SWP_NOMOVE = 0) then
     757     begin
     758       FLeft := Message.WindowPos^.x;
     759       FTop := Message.WindowPos^.y;
     760     end;
     761     if (Message.WindowPos^.flags and SWP_NOSIZE = 0) then
     762     begin
     763       bChanged := ((Message.WindowPos^.cx <> FWidth) or (Message.WindowPos^.cy <> FHeight)) and
     764         (Message.WindowPos^.flags and SWP_NOSIZE = 0);
     765       FWidth := Message.WindowPos^.cx;
     766       FHeight := Message.WindowPos^.cy;
     767     end;
     768   end;
     769 
     770   if (Message.WindowPos^.flags and SWP_FRAMECHANGED <> 0) then
     771     bChanged := True;
     772 
     773   if bChanged then
     774   begin
     775     ChangeSize;
     776     InvalidateNC;
     777   end;
     778 end;
     779 
     780 procedure TskForm.WMNCLButtonDown(var message: TWMNCLButtonDown);
     781 var
     782   iHit: integer;
     783 begin
     784   iHit := HTNOWHERE;
     785   if (Message.HitTest = HTCLOSE) or (Message.HitTest = HTMAXBUTTON) or (Message.HitTest = HTMINBUTTON) or
     786     (Message.HitTest = HTHELP) or (Message.HitTest > HTCUSTOM) then
     787     iHit := Message.HitTest;
     788 
     789 
     790   /// 只处理系统按钮和自定义区域
     791   if iHit <> HTNOWHERE then
     792   begin
     793     if iHit <> FPressedHit then
     794     begin
     795       FPressedHit := iHit;
     796       if FPressedHit = HTCAPTIONTOOLBAR then
     797         FToolbar.HandleMessage(TMessage(message));
     798       InvalidateNC;
     799     end;
     800 
     801     Message.Result := 0;
     802     Message.Msg := WM_NULL;
     803     Handled := True;
     804   end;
     805 end;
     806 
     807 procedure TskForm.WMNCLButtonUp(var Message: TWMNCLButtonUp);
     808 var
     809   iWasHit: Integer;
     810 begin
     811   iWasHit := FPressedHit;
     812   if iWasHit <> HTNOWHERE then
     813   begin
     814     FPressedHit := HTNOWHERE;
     815     //InvalidateNC;
     816 
     817     if iWasHit = FHotHit then
     818     begin
     819       case Message.HitTest of
     820         HTCLOSE           : SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, 0);
     821         HTMAXBUTTON       : Maximize;
     822         HTMINBUTTON       : Minimize;
     823         HTHELP            : SendMessage(Handle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0);
     824 
     825         HTCAPTIONTOOLBAR  : FToolbar.HandleMessage(TMessage(Message));
     826       end;
     827 
     828       Message.Result := 0;
     829       Message.Msg := WM_NULL;
     830       Handled := True;
     831     end;
     832   end;
     833 end;
     834 
     835 procedure TskForm.WMNCMouseMove(var Message: TWMNCMouseMove);
     836 begin
     837   if Message.HitTest = HTCAPTIONTOOLBAR then
     838   begin
     839     FToolbar.HandleMessage(TMessage(Message));
     840     Handled := True;
     841   end
     842   else
     843   begin
     844     if (FPressedHit <> HTNOWHERE) and (FPressedHit <> Message.HitTest) then
     845       FPressedHit := HTNOWHERE;
     846   end;
     847 end;
     848 
     849 procedure TskForm.WMSetText(var Message: TMessage);
     850 begin
     851   CallDefaultProc(Message);
     852   InvalidateNC;
     853   Handled := true;
     854 end;
     855 
     856 procedure TskForm.WMNCPaint(var message: TWMNCPaint);
     857 var
     858   DC: HDC;
     859 begin
     860   DC := GetWindowDC(Control.Handle);
     861   PaintNC(DC);
     862   ReleaseDC(Handle, DC);
     863   Handled := True;
     864 end;
     865 
     866 procedure TskForm.WMNCUAHDrawCaption(var message: TMessage);
     867 begin
     868   /// 这个消息会在winxp下产生,是内部Bug处理,直接丢弃此消息
     869   Handled := True;
     870 end;
     871 
     872 procedure TskForm.WMPaint(var message: TWMPaint);
     873 var
     874   DC, hPaintDC: HDC;
     875   cBuffer: TBitmap;
     876   PS: TPaintStruct;
     877 begin
     878   ///
     879   /// 绘制客户区域
     880   ///
     881   DC := Message.DC;
     882 
     883   hPaintDC := DC;
     884   if DC = 0 then
     885     hPaintDC := BeginPaint(Handle, PS);
     886 
     887   if DC = 0 then
     888   begin
     889     /// 缓冲模式绘制,减少闪烁
     890     cBuffer := TBitmap.Create;
     891     try
     892       cBuffer.SetSize(FWidth, FHeight);
     893       PaintBackground(cBuffer.Canvas.Handle);
     894       Paint(cBuffer.Canvas.Handle);
     895       /// 通知子控件进行绘制
     896       /// 主要是些图形控件的重绘制(如TShape),否则停靠在Form上的图像控件无法正常显示
     897       if Control is TWinControl then
     898         TacWinControl(Control).PaintControls(cBuffer.Canvas.Handle, nil);
     899       BitBlt(hPaintDC, 0, 0, FWidth, FHeight, cBuffer.Canvas.Handle, 0, 0, SRCCOPY);
     900     finally
     901       cBuffer.Free;
     902     end;
     903   end
     904   else
     905   begin
     906     Paint(hPaintDC);
     907     // 通知子控件重绘
     908     if Control is TWinControl then
     909       TacWinControl(Control).PaintControls(hPaintDC, nil);
     910   end;
     911 
     912   if DC = 0 then
     913     EndPaint(Handle, PS);
     914 
     915   Handled := True;
     916 end;
     917 
     918 procedure TskForm.WndProc(var message: TMessage);
     919 begin
     920   FHandled := False;
     921   Dispatch(message);
     922 end;
     923 
     924 class procedure Res.LoadBitmap(const AName: string; AGraphic: TBitmap);
     925 var
     926   cPic: TPngImage;
     927   cBmp: TBitmap;
     928 begin
     929   cBmp := AGraphic;
     930   cPic := TPngImage.Create;
     931   try
     932     cBmp.PixelFormat := pf32bit;
     933     cBmp.alphaFormat := afIgnored;
     934     try
     935       LoadGraphic(AName, cPic);
     936       cBmp.SetSize(cPic.Width, cPic.Height);
     937       cBmp.Canvas.Brush.Color := clBlack;
     938       cBmp.Canvas.FillRect(Rect(0, 0, cBmp.Width, cBmp.Height));
     939       cBmp.Canvas.Draw(0, 0, cPic);
     940     except
     941       // 不处理空图片
     942     end;
     943   finally
     944     cPic.Free;
     945   end;
     946 end;
     947 
     948 class procedure Res.LoadGraphic(const AName: string; AGraphic: TGraphic);
     949 var
     950   cStream: TResourceStream;
     951   h: THandle;
     952 begin
     953   ///
     954   /// 加载图片资源
     955   h := HInstance;
     956   cStream := TResourceStream.Create(h, AName, RT_RCDATA);
     957   try
     958     AGraphic.LoadFromStream(cStream);
     959   finally
     960     cStream.Free;
     961   end;
     962 end;
     963 
     964 class constructor SkinData.Create;
     965 begin
     966   // 加载资源
     967   FData := TBitmap.Create;
     968   Res.LoadBitmap('MySkin', FData);
     969 end;
     970 
     971 class destructor SkinData.Destroy;
     972 begin
     973   FData.Free;
     974 end;
     975 
     976 class procedure SkinData.DrawButton(DC: HDC; AKind: TFormButtonKind; AState:
     977     TSkinIndicator; const R: TRect);
     978 var
     979   rSrcOff: TPoint;
     980   x, y: integer;
     981 begin
     982   /// 绘制背景
     983   DrawButtonBackground(DC, AState, R);
     984 
     985   /// 绘制图标
     986   rSrcOff := Point(SIZE_RESICON * ord(AKind), 0);
     987   x := R.Left + (R.Right - R.Left - SIZE_RESICON) div 2;
     988   y := R.Top + (R.Bottom - R.Top - SIZE_RESICON) div 2;
     989   DrawTransparentBitmap(FData, rSrcOff.X, rSrcOff.Y, DC, x, y, SIZE_RESICON, SIZE_RESICON);
     990 end;
     991 
     992 class procedure SkinData.DrawButtonBackground(DC: HDC; AState: TSkinIndicator; const R: TRect; const Opacity: Byte = 255);
     993 var
     994   hB: HBRUSH;
     995   iColor: Cardinal;
     996 begin
     997   if AState <> siInactive then
     998   begin
     999     /// 绘制背景
    1000     case AState of
    1001       siHover         : iColor := SKINCOLOR_BTNHOT;
    1002       siPressed       : iColor := SKINCOLOR_BTNPRESSED;
    1003       siSelected      : iColor := SKINCOLOR_BTNPRESSED;
    1004       siHoverSelected : iColor := SKINCOLOR_BTNHOT;
    1005     else                iColor := SKINCOLOR_BAKCGROUND;
    1006     end;
    1007     hB := CreateSolidBrush(iColor);
    1008     FillRect(DC, R, hB);
    1009     DeleteObject(hB);
    1010   end;
    1011 end;
    1012 
    1013 class procedure SkinData.DrawElement(DC: HDC; AItem: TSkinToolbarElement; const R: TRect);
    1014 var
    1015   rSrc: TResArea;
    1016   x, y: integer;
    1017 begin
    1018   rSrc := RES_CAPTIONTOOLBAR;
    1019   rSrc.x :=  rSrc.x + rSrc.w * (ord(AItem) - ord(Low(TSkinToolbarElement)));
    1020 
    1021   /// 绘制图标
    1022   x := R.Left + (R.Right - R.Left - rSrc.w) div 2;
    1023   y := R.Top + (R.Bottom - R.Top - rSrc.h) div 2;
    1024   DrawTransparentBitmap(FData, rSrc.x, rSrc.y, DC, x, y, rSrc.w, rSrc.h);
    1025 end;
    1026 
    1027 class procedure SkinData.DrawIcon(DC: HDC; R: TRect; ASrc: TBitmap; const Opacity: Byte = 255);
    1028 var
    1029   iXOff: Integer;
    1030   iYOff: Integer;
    1031 begin
    1032   iXOff := r.Left + (R.Right - R.Left - ASrc.Width) div 2;
    1033   iYOff := r.Top + (r.Bottom - r.Top - ASrc.Height) div 2;
    1034   DrawTransparentBitmap(ASrc, 0, 0, DC, iXOff, iYOff, ASrc.Width, ASrc.Height, Opacity);
    1035 end;
    1036 
    1037 { TcpToolbar }
    1038 constructor TcpToolbar.Create(AOwner: TskForm);
    1039 begin
    1040   inherited;
    1041   FHotIndex := -1;
    1042   FPressedIndex := -1;
    1043 end;
    1044 
    1045 procedure TcpToolbar.Add(Action: TBasicAction; AImageIndex: Integer);
    1046 begin
    1047   if FCount >= Length(FItems) then
    1048     SetLength(FItems, FCount + 5);
    1049 
    1050   ZeroMemory(@FItems[FCount], SizeOf(TcpToolButton));
    1051   FItems[FCount].Action := Action;
    1052   FItems[FCount].Enabled := true;
    1053   FItems[FCount].Visible := True;
    1054   FItems[FCount].ImageIndex := AImageIndex;
    1055   FItems[FCount].Width := 20;
    1056   FItems[FCount].Fade  := 255;
    1057   FItems[FCount].SaveEvent := TacAction(Action).OnChange;
    1058   TacAction(Action).OnChange := DoOnActionChange;
    1059 
    1060   inc(FCount);
    1061 
    1062   Update;
    1063 end;
    1064 
    1065 function TcpToolbar.CalcSize: TRect;
    1066 const
    1067   SIZE_SPLITER = 10;
    1068   SIZE_POPMENU = 10;
    1069   SIZE_BUTTON  = 20;
    1070 var
    1071   w, h: Integer;
    1072   I: Integer;
    1073 begin
    1074   ///
    1075   ///  占用宽度
    1076   ///     如果考虑比较复杂的按钮样式和显示标题等功能,那么需要计算每个按钮实际占用宽度才能获得。
    1077 
    1078   w := SIZE_SPLITER * 2 + SIZE_POPMENU;
    1079   for I := 0 to FCount - 1 do
    1080     w := w + FItems[i].Width;
    1081   h := SIZE_BUTTON;
    1082   Result := Rect(0, 0, w, h);
    1083 end;
    1084 
    1085 procedure TcpToolbar.Delete(Index: Integer);
    1086 begin
    1087   if (Index >= 0) and (Index < FCount) then
    1088   begin
    1089     /// 删除时需要恢复
    1090     TacAction(FItems[Index].Action).OnChange := FItems[Index].SaveEvent;
    1091 
    1092     if Index < (FCount - 1) then
    1093       Move(FItems[Index+1], FItems[Index], sizeof(TcpToolButton) * (FCount - Index - 1));
    1094     dec(FCount);
    1095 
    1096     Update;
    1097   end;
    1098 end;
    1099 
    1100 procedure TcpToolbar.DoOnActionChange(Sender: TObject);
    1101 var
    1102   idx: Integer;
    1103   bResize: Boolean;
    1104 begin
    1105   if Sender is TBasicAction then
    1106   begin
    1107     idx := IndexOf(TBasicAction(Sender));
    1108     if (idx >= 0) and (idx < FCount) then
    1109     begin
    1110       ///
    1111       ///  外部状态改变响应
    1112       ///
    1113       if FItems[idx].Action.InheritsFrom(TContainedAction) then
    1114       begin
    1115         FItems[idx].Enabled := TContainedAction(Sender).Enabled;
    1116         bResize := FItems[idx].Visible <> TContainedAction(Sender).Visible;
    1117         if bResize then
    1118         begin
    1119           FItems[idx].Visible := not FItems[idx].Visible;
    1120           Update
    1121         end
    1122         else
    1123           Invalidate;
    1124       end;
    1125 
    1126       /// 执行原有事件
    1127       if Assigned(FItems[idx].SaveEvent) then
    1128         FItems[idx].SaveEvent(Sender);
    1129     end;
    1130   end;
    1131 end;
    1132 
    1133 function TcpToolbar.HitTest(P: TPoint): integer;
    1134 var
    1135   iOff: Integer;
    1136   iIdx: integer;
    1137   I: Integer;
    1138 begin
    1139   ///
    1140   ///  检测鼠标位置
    1141   ///    鼠标位置的 FCount位 为工具条系统菜单位置。
    1142   iIdx := -1;
    1143   iOff := RES_CAPTIONTOOLBAR.w;
    1144   if p.x > iOff then
    1145   begin
    1146     for I := 0 to FCount - 1 do
    1147     begin
    1148       if p.X < iOff then
    1149         Break;
    1150 
    1151       iIdx := i;
    1152       inc(iOff, FItems[i].Width);
    1153     end;
    1154 
    1155     if p.x > iOff then
    1156     begin
    1157       iIdx := -1;
    1158       inc(iOff, RES_CAPTIONTOOLBAR.w);
    1159       if p.x > iOff then
    1160         iIdx := FCount;  // FCount 为系统菜单按钮
    1161     end;
    1162   end;
    1163 
    1164   Result := iIdx;
    1165 end;
    1166 
    1167 procedure TcpToolbar.ExecAction(Index: Integer);
    1168 begin
    1169   ///
    1170   /// 执行命令
    1171   ///
    1172   if (Index >= 0) and (Index < FCount) then
    1173     FItems[Index].Action.Execute;
    1174 
    1175   // FCount位 为系统配置按钮
    1176   if Index = FCount then
    1177     PopConfigMenu;
    1178 end;
    1179 
    1180 procedure TcpToolbar.PopConfigMenu;
    1181 begin
    1182 end;
    1183 
    1184 procedure TcpToolbar.SetImages(const Value: TCustomImageList);
    1185 begin
    1186   FImages := Value;
    1187   Invalidate;
    1188 end;
    1189 
    1190 function TcpToolbar.IndexOf(Action: TBasicAction): Integer;
    1191 var
    1192   I: Integer;
    1193 begin
    1194   Result := -1;
    1195   for I := 0 to FCount - 1 do
    1196     if FItems[i].Action = Action then
    1197     begin
    1198       Result := i;
    1199       Break;
    1200     end;
    1201 end;
    1202 
    1203 procedure TcpToolbar.MouseDown(Button: TMouseButton; p: TPoint);
    1204 begin
    1205   if (mbLeft = Button) then
    1206   begin
    1207     FPressedIndex := HitTest(p);
    1208     //Invalidate;
    1209   end;
    1210 end;
    1211 
    1212 procedure TcpToolbar.MouseLeave;
    1213 begin
    1214   if FHotIndex >= 0 then
    1215   begin
    1216     FHotIndex := -1;
    1217     //Invalidate;
    1218   end;
    1219 end;
    1220 
    1221 procedure TcpToolbar.HitWindowTest(P: TPoint);
    1222 begin
    1223   FHotIndex := HitTest(P);
    1224 end;
    1225 
    1226 procedure TcpToolbar.MouseMove(p: TPoint);
    1227 var
    1228   iIdx: Integer;
    1229 begin
    1230   iIdx := HitTest(p);
    1231   if iIdx <> FHotIndex then
    1232   begin
    1233     FHotIndex := iIdx;
    1234     Invalidate;
    1235   end;
    1236 end;
    1237 
    1238 procedure TcpToolbar.MouseUp(Button: TMouseButton; p: TPoint);
    1239 var
    1240   iAction: Integer;
    1241 begin
    1242   if (mbLeft = Button) and (FPressedIndex >= 0) and (FHotIndex = FPressedIndex) then
    1243   begin
    1244     iAction := FPressedIndex;
    1245     FPressedIndex := -1;
    1246     Invalidate;
    1247 
    1248     ExecAction(iAction);
    1249   end;
    1250 end;
    1251 
    1252 function TcpToolbar.LoadActionIcon(Idx: Integer; AImg: TBitmap):Boolean;
    1253 var
    1254   bHasImg: Boolean;
    1255 begin
    1256   /// 获取Action的图标
    1257   AImg.Canvas.Brush.Color := clBlack;
    1258   AImg.Canvas.FillRect(Rect(0,0, AImg.Width, AImg.Height));
    1259   bHasImg := False;
    1260   if (FImages <> nil) and (FItems[Idx].ImageIndex >= 0) then
    1261     bHasImg := FImages.GetBitmap(FItems[Idx].ImageIndex, AImg);
    1262   if not bHasImg and (FItems[Idx].Action is TCustomAction) then
    1263     with TCustomAction(FItems[Idx].Action) do
    1264       if (Images <> nil) and (ImageIndex >= 0) then
    1265         bHasImg := Images.GetBitmap(ImageIndex, AImg);
    1266   Result := bHasImg;
    1267 end;
    1268 
    1269 procedure TcpToolbar.Paint(DC: HDC);
    1270 
    1271   function GetActionState(Idx: Integer): TSkinIndicator;
    1272   begin
    1273     Result := siInactive;
    1274     if (Idx = FPressedIndex) and (FHotIndex = FPressedIndex) then
    1275       Result := siPressed
    1276     else if Idx = FHotIndex then
    1277       Result := siHover;
    1278   end;
    1279 
    1280 var
    1281   cIcon: TBitmap;
    1282   r: TRect;
    1283   I: Integer;
    1284   iOpacity: byte;
    1285 begin
    1286   ///
    1287   ///  工具条绘制
    1288   ///
    1289 
    1290   /// 分割线
    1291   r := Border;
    1292   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    1293   SkinData.DrawElement(DC, steSplitter, r);
    1294   OffsetRect(r, r.Right - r.Left, 0);
    1295 
    1296   /// 绘制Button
    1297   cIcon := TBitmap.Create;
    1298   cIcon.PixelFormat := pf32bit;
    1299   cIcon.alphaFormat := afIgnored;
    1300   for I := 0 to FCount - 1 do
    1301   begin
    1302     r.Right := r.Left + FItems[i].Width;
    1303     if FItems[I].Enabled then
    1304       SkinData.DrawButtonBackground(DC, GetActionState(i), r, FItems[i].Fade);
    1305     if LoadActionIcon(i, cIcon) then
    1306     begin
    1307       iOpacity := 255;
    1308       /// 处理不可用状态,图标颜色变暗。
    1309       ///   简易处理,增加绘制透明度。
    1310       if not FItems[i].Enabled then
    1311         iOpacity := 100;
    1312 
    1313       SkinData.DrawIcon(DC, r, cIcon, iOpacity);
    1314     end;
    1315     OffsetRect(r, r.Right - r.Left, 0);
    1316   end;
    1317   cIcon.free;
    1318 
    1319   /// 分割条
    1320   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    1321   SkinData.DrawElement(DC, steSplitter, r);
    1322   OffsetRect(r, r.Right - r.Left, 0);
    1323 
    1324   /// 绘制下拉菜单
    1325   r.Right := r.Left + RES_CAPTIONTOOLBAR.w;
    1326   SkinData.DrawElement(DC, stePopdown, r);
    1327 end;
    1328 
    1329 constructor TFormCaptionPlugin.Create(AOwner: TskForm);
    1330 begin
    1331   FOwner := AOwner;
    1332   FVisible := True;
    1333   FBorder := CalcSize;
    1334   FOffset.X := -1;
    1335 end;
    1336 
    1337 function TFormCaptionPlugin.ScreenToClient(x, y: Integer): TPoint;
    1338 var
    1339   P: TPoint;
    1340 begin
    1341   /// 调整位置
    1342   ///    以 FOffset 为中心位置
    1343   P := FOwner.NormalizePoint(Point(x, Y));
    1344   p.X := p.X - FOffset.X;
    1345   p.Y := p.y - FOffset.Y;
    1346 
    1347   Result := p;
    1348 end;
    1349 
    1350 
    1351 function TFormCaptionPlugin.HandleMessage(var Message: TMessage): Boolean;
    1352 begin
    1353   Result := True;
    1354 
    1355   case Message.Msg of
    1356     WM_NCMOUSEMOVE    : MouseMove(ScreenToClient(TWMNCMouseMove(Message).XCursor, TWMNCMouseMove(Message).YCursor));
    1357     WM_NCLBUTTONDOWN  : MouseDown(mbLeft, ScreenToClient(TWMNCLButtonDown(Message).XCursor, TWMNCLButtonDown(Message).YCursor));
    1358     WM_NCHITTEST      : HitWindowTest(ScreenToClient(TWMNCHitTest(Message).XPos, TWMNCHitTest(Message).YPos));
    1359     WM_NCLBUTTONUP    : MouseUp(mbLeft, ScreenToClient(TWMNCLButtonUp(Message).XCursor, TWMNCLButtonUp(Message).YCursor));
    1360 
    1361     else
    1362       Result := False;
    1363   end;
    1364 end;
    1365 
    1366 procedure TFormCaptionPlugin.HitWindowTest(P: TPoint);
    1367 begin
    1368 end;
    1369 
    1370 procedure TFormCaptionPlugin.Invalidate;
    1371 begin
    1372   FOwner.InvalidateNC;
    1373 end;
    1374 
    1375 procedure TFormCaptionPlugin.MouseDown(Button: TMouseButton; p: TPoint);
    1376 begin
    1377 end;
    1378 
    1379 procedure TFormCaptionPlugin.MouseLeave;
    1380 begin
    1381 end;
    1382 
    1383 procedure TFormCaptionPlugin.MouseMove(p: TPoint);
    1384 begin
    1385 end;
    1386 
    1387 procedure TFormCaptionPlugin.MouseUp(Button: TMouseButton; p: TPoint);
    1388 begin
    1389 end;
    1390 
    1391 procedure TFormCaptionPlugin.Update;
    1392 begin
    1393   FBorder := CalcSize;
    1394   Invalidate;
    1395 end;
    1396 
    1397 end.
    uFormSkins.pas
      1 unit ufrmCaptionToolbar;
      2 
      3 interface
      4 
      5 uses
      6   Messages, SysUtils, Variants, Types, Controls, Forms, Dialogs, StdCtrls,
      7   ExtCtrls, ComCtrls, Windows, Classes, Graphics, Actions, ActnList, ToolWin,
      8   Vcl.ImgList, Vcl.Buttons,
      9 
     10   uFormSkins;
     11 
     12 type
     13   TForm11 = class(TForm)
     14     Button1: TButton;
     15     Shape1: TShape;
     16     Edit1: TEdit;
     17     Edit2: TEdit;
     18     Edit3: TEdit;
     19     Edit4: TEdit;
     20     ToolBar1: TToolBar;
     21     ToolButton1: TToolButton;
     22     ToolButton2: TToolButton;
     23     ToolButton3: TToolButton;
     24     ActionList1: TActionList;
     25     Action1: TAction;
     26     Action2: TAction;
     27     Action3: TAction;
     28     ImageList1: TImageList;
     29     ImageList2: TImageList;
     30     CheckBox1: TCheckBox;
     31     procedure FormCreate(Sender: TObject);
     32     procedure Action1Execute(Sender: TObject);
     33     procedure Action2Execute(Sender: TObject);
     34     procedure Action3Execute(Sender: TObject);
     35     procedure CheckBox1Click(Sender: TObject);
     36     procedure SpeedButton1Click(Sender: TObject);
     37   private
     38     FTest: TskForm;
     39   protected
     40 
     41     procedure WndProc(var message: TMessage); override;
     42   public
     43     constructor Create(AOwner: TComponent); override;
     44     destructor Destroy; override;
     45   end;
     46 
     47 var
     48   Form11: TForm11;
     49 
     50 implementation
     51 
     52 
     53 {$R *.dfm}
     54 
     55 
     56 
     57 { TForm11 }
     58 
     59 constructor TForm11.Create(AOwner: TComponent);
     60 begin
     61   FTest := TskForm.Create(Self);
     62   inherited;
     63 end;
     64 
     65 procedure TForm11.FormCreate(Sender: TObject);
     66 begin
     67   FTest.Toolbar.Images := ImageList2;
     68   FTest.Toolbar.Add(Action1, 0);
     69   FTest.Toolbar.Add(Action2, 1);
     70   FTest.Toolbar.Add(Action3, 2);
     71 end;
     72 
     73 destructor TForm11.Destroy;
     74 begin
     75   inherited;
     76   FreeAndNil(FTest);
     77 end;
     78 
     79 procedure TForm11.Action1Execute(Sender: TObject);
     80 begin
     81   Tag := Tag + 1;
     82   Caption := format('test %d', [Tag]);
     83 end;
     84 
     85 procedure TForm11.Action2Execute(Sender: TObject);
     86 begin
     87   if Shape1.Shape <> High(TShapeType) then
     88     Shape1.Shape := Succ(Shape1.Shape)
     89   else
     90     Shape1.Shape := low(TShapeType);
     91 end;
     92 
     93 procedure TForm11.Action3Execute(Sender: TObject);
     94 begin
     95   Action1.Enabled := not Action1.Enabled;
     96 end;
     97 
     98 procedure TForm11.CheckBox1Click(Sender: TObject);
     99 begin
    100   if CheckBox1.Checked then
    101     FTest.Toolbar.Images := nil
    102   else
    103     FTest.Toolbar.Images := ImageList2;
    104 end;
    105 
    106 procedure TForm11.SpeedButton1Click(Sender: TObject);
    107 begin
    108   Caption := format('test %d', [1]);
    109 end;
    110 
    111 procedure TForm11.WndProc(var message: TMessage);
    112 begin
    113   if not FTest.DoHandleMessage(Message) then
    114     inherited;
    115 end;
    116 
    117 end.
    ufrmCaptionToolbar.pas

      

    相关API

      MoveWindowOrg                ---- 设置绘制原点

      CreateRectRgnIndirect        ---- 创建区域

      SelectClipRgn                     ---- 剪切绘制区域

    相关功能实现:

      其实这个功能在Win7下已经有此接口可以实现(很久以前用过具体名字忘记了,没写日志的后果-_-),系统自带的画图就是使用此接口实现的。但有个问题就是XP下木有此功能。感兴趣的可以Google一下。   

    开发环境

       XE3

       Win7

    完整源代码

        https://github.com/cmacro/simple/tree/master/TestCaptionToolbar

    蘑菇房 (moguf.com)

  • 相关阅读:
    iOS开发中常见错误总结(1)
    iOS开发——OC篇&纯代码退出键盘
    获取下拉框
    @RequestBody 注解
    form 表单提交
    数据库excel导出
    状态模式
    图书网上商城实现(一)
    MongoDB(一)—— 搭建环境和启动服务
    MySQL开发遇到的问题
  • 原文地址:https://www.cnblogs.com/gleam/p/3975414.html
Copyright © 2011-2022 走看看