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