窗体边框基本的绘制和控制完成,在第二篇中主要遗留的问题。
- 标题区域图标和按钮没绘制
- 缩放时客户区显示有问题
解决完下面的问题,皮肤处理基本完整。大致的效果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;
上面代码获取当前鼠标所在位置,这样滑入的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;
整个标题区的消息基本处理完成,能正常相应标题区应有的功能。还有些细节上面需要处理一下,如修改窗体标题没有及时响应。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;
感觉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