前面做的工作就是想在标题区域增加快速工具条。前续的基础工作完成，想要在标题区域增加特殊区域都非常方便。只要在绘制时控制自定义区域需要占用标题区域多少空间，然后直接在所占位置绘制。做这个事情前，稍微把代码规整了下。所以界面皮肤处理放到一个单元中。
主要处理步骤
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
时间： 2024-10-06 20:00:07