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