首页 > 代码库 > 窗体皮肤实现 - 在标题栏上增加快速工具条（四）
窗体皮肤实现 - 在标题栏上增加快速工具条（四）
前面做的工作就是想在标题区域增加快速工具条。前续的基础工作完成，想要在标题区域增加特殊区域都非常方便。只要在绘制时控制自定义区域需要占用标题区域多少空间，然后直接在所占位置绘制。做这个事情前，稍微把代码规整了下。所以界面皮肤处理放到一个单元中。
主要处理步骤
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) then14 begin15 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 then21 FToolbar.FOffset := r.TopLeft;22 23 if PtInRect(r, p) then24 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 const16 SIZE_SPLITER = 10;17 SIZE_POPMENU = 10;18 SIZE_BUTTON = 20;19 var20 w, h: Integer;21 I: Integer;22 begin23 ///24 /// 占用宽度25 /// 如果考虑比较复杂的按钮样式和显示标题等功能，那么需要计算每个按钮实际占用宽度才能获得。26 27 w := SIZE_SPLITER * 2 + SIZE_POPMENU;28 for I := 0 to FCount - 1 do29 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 then10 begin11 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 then24 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 begin10 /// 获取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) then15 bHasImg := FImages.GetBitmap(FItems[Idx].ImageIndex, AImg);16 if not bHasImg and (FItems[Idx].Action is TCustomAction) then17 with TCustomAction(FItems[Idx].Action) do18 if (Images <> nil) and (ImageIndex >= 0) then19 bHasImg := Images.GetBitmap(ImageIndex, AImg);20 Result := bHasImg;21 end;
绘制工具条
有了尺寸和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 var13 cIcon: TBitmap;14 r: TRect;15 I: Integer;16 iOpacity: byte;17 begin18 ///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 /// 绘制Button29 cIcon := TBitmap.Create;30 cIcon.PixelFormat := pf32bit;31 cIcon.alphaFormat := afIgnored;32 for I := 0 to FCount - 1 do33 begin34 r.Right := r.Left + FItems[i].Width;35 if FItems[I].Enabled then36 SkinData.DrawButtonBackground(DC, GetActionState(i), r, FItems[i].Fade);37 if LoadActionIcon(i, cIcon) then38 begin39 iOpacity := 255;40 /// 处理不可用状态，图标颜色变暗。41 /// 简易处理，增加绘制透明度。42 if not FItems[i].Enabled then43 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 else12 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 then13 begin14 for I := 0 to FCount - 1 do15 begin16 if p.X < iOff then17 Break;18 19 iIdx := i;20 inc(iOff, FItems[i].Width);21 end;22 23 if p.x > iOff then24 begin25 iIdx := -1;26 inc(iOff, RES_CAPTIONTOOLBAR.w);27 if p.x > iOff then28 iIdx := FCount; // FCount 为系统菜单按钮29 end;30 end;31 32 Result := iIdx;33 end;
还有些细节方面的处理，如鼠标离开这个区域时的处理。这样整个工具区的基本处理完成，整个工具条区域的处理还是相对比较简单。
Action状态处理
Action处理主要是考虑，当外部改变Action状态。如：无效，不可见的一些事件处理。标准的处理方法是在关联Action是创建一个ActionLink实现联动，由于TskForm没有从TControl继承，没法使用此方法进行处理。在TBasicAction改变状态时会触发一个OnChange的保护（protected）事件，可以直接把事件挂接上去，就能简单处理状态。
保护方法的访问：创建一个访问类，进行引用。
1 type2 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) then10 begin11 ///12 /// 外部状态改变响应13 ///14 if FItems[idx].Action.InheritsFrom(TContainedAction) then15 begin16 FItems[idx].Enabled := TContainedAction(Sender).Enabled;17 bResize := FItems[idx].Visible <> TContainedAction(Sender).Visible;18 if bResize then19 begin20 FItems[idx].Visible := not FItems[idx].Visible;21 Update22 end23 else24 Invalidate;25 end;26 27 /// 执行原有事件28 if Assigned(FItems[idx].SaveEvent) then29 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 then11 iOpacity := 100;12 13 SkinData.DrawIcon(DC, r, cIcon, iOpacity);14 end;15 ... ...16 17 // 获取Action底色的显示状态18 // 按下状态、滑过状态、默认状态19 function GetActionState(Idx: Integer): TSkinIndicator;20 begin21 Result := siInactive;22 if (Idx = FPressedIndex) and (FHotIndex = FPressedIndex) then23 Result := siPressed24 else if Idx = FHotIndex then25 Result := siHover;26 end;27
在窗体上加入测试Action
1 procedure TForm11.FormCreate(Sender: TObject);2 begin3 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 = http://www.mamicode.com/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 of1001 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 var1015 rSrc: TResArea;1016 x, y: integer;1017 begin1018 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 var1029 iXOff: Integer;1030 iYOff: Integer;1031 begin1032 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 begin1040 inherited;1041 FHotIndex := -1;1042 FPressedIndex := -1;1043 end;1044 1045 procedure TcpToolbar.Add(Action: TBasicAction; AImageIndex: Integer);1046 begin1047 if FCount >= Length(FItems) then1048 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 const1067 SIZE_SPLITER = 10;1068 SIZE_POPMENU = 10;1069 SIZE_BUTTON = 20;1070 var1071 w, h: Integer;1072 I: Integer;1073 begin1074 ///1075 /// 占用宽度1076 /// 如果考虑比较复杂的按钮样式和显示标题等功能，那么需要计算每个按钮实际占用宽度才能获得。1077 1078 w := SIZE_SPLITER * 2 + SIZE_POPMENU;1079 for I := 0 to FCount - 1 do1080 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 begin1087 if (Index >= 0) and (Index < FCount) then1088 begin1089 /// 删除时需要恢复1090 TacAction(FItems[Index].Action).OnChange := FItems[Index].SaveEvent;1091 1092 if Index < (FCount - 1) then1093 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 var1102 idx: Integer;1103 bResize: Boolean;1104 begin1105 if Sender is TBasicAction then1106 begin1107 idx := IndexOf(TBasicAction(Sender));1108 if (idx >= 0) and (idx < FCount) then1109 begin1110 ///1111 /// 外部状态改变响应1112 ///1113 if FItems[idx].Action.InheritsFrom(TContainedAction) then1114 begin1115 FItems[idx].Enabled := TContainedAction(Sender).Enabled;1116 bResize := FItems[idx].Visible <> TContainedAction(Sender).Visible;1117 if bResize then1118 begin1119 FItems[idx].Visible := not FItems[idx].Visible;1120 Update1121 end1122 else1123 Invalidate;1124 end;1125 1126 /// 执行原有事件1127 if Assigned(FItems[idx].SaveEvent) then1128 FItems[idx].SaveEvent(Sender);1129 end;1130 end;1131 end;1132 1133 function TcpToolbar.HitTest(P: TPoint): integer;1134 var1135 iOff: Integer;1136 iIdx: integer;1137 I: Integer;1138 begin1139 ///1140 /// 检测鼠标位置1141 /// 鼠标位置的 FCount位 为工具条系统菜单位置。1142 iIdx := -1;1143 iOff := RES_CAPTIONTOOLBAR.w;1144 if p.x > iOff then1145 begin1146 for I := 0 to FCount - 1 do1147 begin1148 if p.X < iOff then1149 Break;1150 1151 iIdx := i;1152 inc(iOff, FItems[i].Width);1153 end;1154 1155 if p.x > iOff then1156 begin1157 iIdx := -1;1158 inc(iOff, RES_CAPTIONTOOLBAR.w);1159 if p.x > iOff then1160 iIdx := FCount; // FCount 为系统菜单按钮1161 end;1162 end;1163 1164 Result := iIdx;1165 end;1166 1167 procedure TcpToolbar.ExecAction(Index: Integer);1168 begin1169 ///1170 /// 执行命令1171 ///1172 if (Index >= 0) and (Index < FCount) then1173 FItems[Index].Action.Execute;1174 1175 // FCount位 为系统配置按钮1176 if Index = FCount then1177 PopConfigMenu;1178 end;1179 1180 procedure TcpToolbar.PopConfigMenu;1181 begin1182 end;1183 1184 procedure TcpToolbar.SetImages(const Value: TCustomImageList);1185 begin1186 FImages := Value;1187 Invalidate;1188 end;1189 1190 function TcpToolbar.IndexOf(Action: TBasicAction): Integer;1191 var1192 I: Integer;1193 begin1194 Result := -1;1195 for I := 0 to FCount - 1 do1196 if FItems[i].Action = Action then1197 begin1198 Result := i;1199 Break;1200 end;1201 end;1202 1203 procedure TcpToolbar.MouseDown(Button: TMouseButton; p: TPoint);1204 begin1205 if (mbLeft = Button) then1206 begin1207 FPressedIndex := HitTest(p);1208 //Invalidate;1209 end;1210 end;1211 1212 procedure TcpToolbar.MouseLeave;1213 begin1214 if FHotIndex >= 0 then1215 begin1216 FHotIndex := -1;1217 //Invalidate;1218 end;1219 end;1220 1221 procedure TcpToolbar.HitWindowTest(P: TPoint);1222 begin1223 FHotIndex := HitTest(P);1224 end;1225 1226 procedure TcpToolbar.MouseMove(p: TPoint);1227 var1228 iIdx: Integer;1229 begin1230 iIdx := HitTest(p);1231 if iIdx <> FHotIndex then1232 begin1233 FHotIndex := iIdx;1234 Invalidate;1235 end;1236 end;1237 1238 procedure TcpToolbar.MouseUp(Button: TMouseButton; p: TPoint);1239 var1240 iAction: Integer;1241 begin1242 if (mbLeft = Button) and (FPressedIndex >= 0) and (FHotIndex = FPressedIndex) then1243 begin1244 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 var1254 bHasImg: Boolean;1255 begin1256 /// 获取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) then1261 bHasImg := FImages.GetBitmap(FItems[Idx].ImageIndex, AImg);1262 if not bHasImg and (FItems[Idx].Action is TCustomAction) then1263 with TCustomAction(FItems[Idx].Action) do1264 if (Images <> nil) and (ImageIndex >= 0) then1265 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 begin1273 Result := siInactive;1274 if (Idx = FPressedIndex) and (FHotIndex = FPressedIndex) then1275 Result := siPressed1276 else if Idx = FHotIndex then1277 Result := siHover;1278 end;1279 1280 var1281 cIcon: TBitmap;1282 r: TRect;1283 I: Integer;1284 iOpacity: byte;1285 begin1286 ///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 /// 绘制Button1297 cIcon := TBitmap.Create;1298 cIcon.PixelFormat := pf32bit;1299 cIcon.alphaFormat := afIgnored;1300 for I := 0 to FCount - 1 do1301 begin1302 r.Right := r.Left + FItems[i].Width;1303 if FItems[I].Enabled then1304 SkinData.DrawButtonBackground(DC, GetActionState(i), r, FItems[i].Fade);1305 if LoadActionIcon(i, cIcon) then1306 begin1307 iOpacity := 255;1308 /// 处理不可用状态，图标颜色变暗。1309 /// 简易处理，增加绘制透明度。1310 if not FItems[i].Enabled then1311 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 begin1331 FOwner := AOwner;1332 FVisible := True;1333 FBorder := CalcSize;1334 FOffset.X := -1;1335 end;1336 1337 function TFormCaptionPlugin.ScreenToClient(x, y: Integer): TPoint;1338 var1339 P: TPoint;1340 begin1341 /// 调整位置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 begin1353 Result := True;1354 1355 case Message.Msg of1356 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 else1362 Result := False;1363 end;1364 end;1365 1366 procedure TFormCaptionPlugin.HitWindowTest(P: TPoint);1367 begin1368 end;1369 1370 procedure TFormCaptionPlugin.Invalidate;1371 begin1372 FOwner.InvalidateNC;1373 end;1374 1375 procedure TFormCaptionPlugin.MouseDown(Button: TMouseButton; p: TPoint);1376 begin1377 end;1378 1379 procedure TFormCaptionPlugin.MouseLeave;1380 begin1381 end;1382 1383 procedure TFormCaptionPlugin.MouseMove(p: TPoint);1384 begin1385 end;1386 1387 procedure TFormCaptionPlugin.MouseUp(Button: TMouseButton; p: TPoint);1388 begin1389 end;1390 1391 procedure TFormCaptionPlugin.Update;1392 begin1393 FBorder := CalcSize;1394 Invalidate;1395 end;1396 1397 end.
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 begin100 if CheckBox1.Checked then101 FTest.Toolbar.Images := nil102 else103 FTest.Toolbar.Images := ImageList2;104 end;105 106 procedure TForm11.SpeedButton1Click(Sender: TObject);107 begin108 Caption := format(‘test %d‘, [1]);109 end;110 111 procedure TForm11.WndProc(var message: TMessage);112 begin113 if not FTest.DoHandleMessage(Message) then114 inherited;115 end;116 117 end.
相关API
MoveWindowOrg ---- 设置绘制原点
CreateRectRgnIndirect ---- 创建区域
SelectClipRgn ---- 剪切绘制区域
相关功能实现：
其实这个功能在Win7下已经有此接口可以实现（很久以前用过具体名字忘记了，没写日志的后果-_-），系统自带的画图就是使用此接口实现的。但有个问题就是XP下木有此功能。感兴趣的可以Google一下。
开发环境
XE3
Win7
完整源代码
https://github.com/cmacro/simple/tree/master/TestCaptionToolbar
窗体皮肤实现 - 在标题栏上增加快速工具条（四）
声明：以上内容来自用户投稿及互联网公开渠道收集整理发布，本网站不拥有所有权，未作人工编辑处理，也不承担相关法律责任，若内容有误或涉及侵权可进行投诉： 投诉/举报 工作人员会在5个工作日内联系你，一经查实，本站将立刻删除涉嫌侵权内容。