Add an extra button to the caption bar of your form (Views: 2141)
Problem/Question/Abstract: How to add an extra button to the caption bar of a form. Answer: unit TitleButton; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TChangedProperty = (cpdown, cpallowallup, cpgroupindex); type TTitleButton = class(Tcomponent) private fbuttonrect: trect; fpressed, ffocused: boolean; fbuttoncaption: string; fwidth: integer; fleft: integer; fvisible: boolean; fhintshow: boolean; fhint: thintwindow; fhinttext: string; fgroupindex: integer; fdown: boolean; fallowallup: boolean; fparent: Tform; fparentwidth: integer; ficonwidth: integer; fcallinheritedevent: boolean; fdefaultwidth: integer; fdefaultheight: integer; ffont: Tfont; ficon: Ticon; fborder3d, fborderthickness: integer; fbuttondown: tnotifyevent; fbuttonmove: tmousemoveevent; fbuttonup: tnotifyevent; pmsghandler: Twndmethod; ppaint: Tnotifyevent; presize: tnotifyevent; gtmp1, gtmp2, gtmp3: boolean; procedure initializevariables; procedure IconChange(Sender: tobject); procedure setbuttonwidth(awidth: integer); procedure setbuttonleft(aleft: integer); procedure setbuttoncaption(acaption: string); procedure setbuttonfont(afont: tfont); procedure setbuttonvisible(avisible: boolean); procedure seticon(aicon: ticon); procedure setdown(adown: boolean); procedure setallowallup(aallowallup: boolean); procedure setgroupindex(agroupindex: integer); procedure UpdateProperties(achangedproperty: TChangedProperty); protected procedure messagehandler(var msg: tmessage); procedure CaptionPaint(var msg: tmessage); procedure CaptionMouseMove(var msg: tmessage); procedure CaptionMouseDown(var msg: tmessage); procedure CaptionMouseUp(var msg: tmessage); procedure CaptionRightMouseDown(var msg: tmessage); procedure CaptionDoubleClick(var msg: tmessage); procedure CaptionActivate(var msg: tmessage); procedure CaptionHitTest(var msg: Tmessage); procedure CaptionChange(var msg: Tmessage); procedure ParentMouseMove(var msg: tmessage); procedure ParentMouseUp(var msg: tmessage); procedure ButtonUp(var msg: tmessage); procedure ParentPaint(sender: tobject); procedure ParentResize(sender: tobject); procedure DisplaySettingChange(var msg: tmessage); procedure loaded; override; public constructor create(aowner: tcomponent); override; destructor destroy; override; published property Width: integer read fwidth write setbuttonwidth; property Position: integer read fleft write setbuttonleft; property Caption: string read fbuttoncaption write setbuttoncaption; property Font: Tfont read ffont write SetButtonFont; property Icon: Ticon read ficon write seticon; property TipText: string read fhinttext write fhinttext; property Visible: boolean read fvisible write setbuttonvisible; property AllowAllUp: boolean read fallowallup write setallowallup; property Down: boolean read fdown write setdown; property GroupIndex: integer read fgroupindex write setgroupindex; property OnMouseDown: tnotifyevent read fbuttondown write fbuttondown; property OnMouseMove: tmousemoveevent read fbuttonmove write fbuttonmove; property OnMouseUp: tnotifyevent read fbuttonup write fbuttonup; end; const TTB_SETBUTTONUP = WM_USER + 1; procedure Register; implementation constructor TTitleButton.create(aowner: tcomponent); begin inherited; fparent := (owner as tform); ffont := tfont.create; fhint := thintwindow.create(self); ficon := ticon.create; end; destructor TTitleButton.destroy; begin if assigned(ficon) then ficon.free; if assigned(ffont) then ffont.free; if assigned(fhint) then fhint.free; inherited; end; procedure TTitleButton.loaded; begin inherited; initializevariables; end; procedure TTitleButton.UpdateProperties(achangedproperty: TChangedProperty); var amsg: tmessage; begin amsg.Msg := TTB_SETBUTTONUP; amsg.WParam := integer(self); amsg.LParamlo := fgroupindex; amsg.LParamHi := word(achangedproperty); amsg.Result := 0; fparent.perform(amsg.msg, amsg.wparam, amsg.lparam); end; procedure TTitleButton.initializevariables; begin if assigned(fparent.WindowProc) then pmsghandler := fparent.WindowProc; fparent.WindowProc := messagehandler; if not (csdesigning in componentstate) then begin if assigned(fparent.onpaint) then ppaint := fparent.onpaint; if assigned(fparent.onresize) then presize := fparent.onresize; fparent.onpaint := parentpaint; fparent.onresize := parentresize; end; fparentwidth := fparent.width; zeromemory(@fbuttonrect, sizeof(fbuttonrect)); fpressed := false; ffocused := false; fhintshow := false; ficonwidth := 16; ficon.Transparent := true; ficon.OnChange := IconChange; fhint.Color := clInfoBk; fcallinheritedevent := false; fdefaultwidth := GetSystemMetrics(SM_CXSIZE); if fwidth fwidth := fdefaultwidth; fdefaultheight := GetSystemMetrics(SM_CYSIZE); fborder3d := GetSystemMetrics(SM_CYEDGE); fborderthickness := GetSystemMetrics(SM_CYSIZEFRAME); gtmp3 := false; end; procedure TTitleButton.IconChange(Sender: tobject); begin parentpaint(fparent); end; procedure TTitleButton.messagehandler(var msg: tmessage); begin if csdesigning in componentstate then begin if msg.Msg = TTB_SETBUTTONUP then begin ButtonUp(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else pmsghandler(msg); end else begin if msg.Msg = WM_NCPAINT then begin CaptionPaint(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCLBUTTONDOWN then begin CaptionMouseDown(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCMOUSEMOVE then begin CaptionMouseMove(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCLBUTTONUP then begin CaptionMouseUp(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCACTIVATE then begin CaptionActivate(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCHITTEST then begin CaptionHitTest(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_LBUTTONUP then begin ParentMouseUp(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_MOUSEMOVE then begin ParentMouseMove(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCRBUTTONDOWN then begin CaptionRightMouseDown(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCLBUTTONDBLCLK then begin CaptionDoubleClick(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_NCLBUTTONDBLCLK then begin CaptionDoubleClick(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_SETTEXT then begin CaptionChange(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = WM_SETTINGCHANGE then begin DisplaySettingChange(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else if msg.Msg = TTB_SETBUTTONUP then begin ButtonUp(msg); if (assigned(pmsghandler)) and (fcallinheritedevent) then pmsghandler(msg); end else pmsghandler(msg); end; end; procedure TTitleButton.CaptionPaint(var msg: tmessage); begin fcallinheritedevent := true; if fvisible = false then exit; invalidaterect(fparent.handle, @fbuttonrect, false); end; procedure TTitleButton.CaptionMouseMove(var msg: tmessage); var pt: tpoint; tmpstate: tshiftstate; fhintwidth: integer; begin fcallinheritedevent := true; if fvisible = false then exit; gtmp1 := fpressed; gtmp2 := ffocused; pt.x := msg.LParamLo - fparent.left; pt.y := msg.LParamHi - fparent.top; if PtInRect(fbuttonrect, pt) then begin ffocused := true; {if (gtmp1<>fpressed) or (gtmp2<>ffocused) then begin invalidaterect(fparent.handle,@fbuttonrect,false); gtmp1:=fpressed; gtmp2:=ffocused; end;} fhintwidth := fhint.Canvas.TextWidth(fhinttext); if (fhintshow = false) and (length(trim(fhinttext)) <> 0) then fhint.ActivateHint(rect(mouse.cursorpos.x, mouse.cursorpos.y + 10, mouse.cursorpos.x + fhintwidth + 7, mouse.cursorpos.y + 25), fhinttext); fhintshow := true; if assigned(fbuttonmove) then fbuttonmove(fparent, tmpstate, pt.x, pt.y); end else begin ffocused := false; fhint.ReleaseHandle; fhintshow := false; end; fcallinheritedevent := true; end; procedure TTitleButton.CaptionMouseDown(var msg: tmessage); var pt: tpoint; tmp1: boolean; callevent: boolean; begin callevent := false; fcallinheritedevent := true; if fvisible = false then exit; fhintshow := false; fhint.releasehandle; if fhintshow = true then fhint.ReleaseHandle; setforegroundwindow(fparent.handle); tmp1 := fpressed; pt.x := msg.LParamLo - fparent.left; pt.y := msg.LParamhi - fparent.top; if ptinrect(fbuttonrect, pt) then begin gtmp3 := true; if fgroupindex = 0 then begin callevent := true; end else begin if not (fdown) then if assigned(fbuttondown) then fbuttondown(fparent); end; fpressed := true; ffocused := true; setcapture(fparent.handle); end else begin fpressed := false; ffocused := false; end; if (tmp1 <> fpressed) then fcallinheritedevent := false; gtmp1 := fpressed; gtmp2 := ffocused; parentpaint(fparent); if (callevent) and assigned(fbuttondown) then fbuttondown(fparent); end; procedure TTitleButton.CaptionMouseUp(var msg: tmessage); var pt: Tpoint; tmp1, tmp2: boolean; begin fcallinheritedevent := true; if fvisible = false then exit; releasecapture; tmp1 := fpressed; tmp2 := ffocused; pt.x := msg.LParamLo - fparent.left; pt.y := msg.LParamhi - fparent.top; if (ptinrect(fbuttonrect, pt)) and (ffocused = true) then fpressed := false else ffocused := false; if ((tmp1 <> fpressed) or (tmp2 <> ffocused)) and (fallowallup and fdown) then invalidaterect(fparent.handle, @fbuttonrect, true); fcallinheritedevent := true; end; procedure TTitleButton.CaptionRightMouseDown(var msg: tmessage); var pt: tpoint; begin fcallinheritedevent := true; if fvisible = false then exit; fhint.releasehandle; pt.x := msg.LParamlo - fparent.left; pt.y := msg.LParamHi - fparent.top; if not ptinrect(fbuttonrect, pt) then fcallinheritedevent := true else fcallinheritedevent := false; end; procedure TTitleButton.CaptionDoubleClick(var msg: tmessage); var pt: tpoint; begin fcallinheritedevent := true; if fvisible = false then exit; pt.x := msg.LParamlo - fparent.left; pt.y := msg.LParamhi - fparent.top; if not (ptinrect(fbuttonrect, pt)) then fcallinheritedevent := true else begin fcallinheritedevent := false; fparent.perform(WM_NCLBUTTONDOWN, msg.wparam, msg.LParam); end; end; procedure TTitleButton.CaptionActivate(var msg: tmessage); begin fcallinheritedevent := true; if not visible then exit; invalidaterect(fparent.handle, @fbuttonrect, false); end; procedure TTitleButton.CaptionHitTest(var msg: Tmessage); var tmp: boolean; pt: tpoint; begin fcallinheritedevent := true; if fvisible = false then exit; if fpressed then begin tmp := ffocused; pt.x := msg.LParamlo - fparent.left; pt.y := msg.LParamhi - fparent.top; if ptinrect(fbuttonrect, pt) then begin ffocused := true end else ffocused := false; if ffocused <> tmp then invalidaterect(fparent.handle, @fbuttonrect, false); end; if ffocused = false then fhint.releasehandle; gtmp1 := fpressed; gtmp2 := ffocused; fcallinheritedevent := true; end; procedure TTitleButton.CaptionChange(var msg: Tmessage); begin fcallinheritedevent := true; if not fvisible then exit; invalidaterect(fparent.handle, @fbuttonrect, false); end; procedure TTitleButton.ButtonUp(var msg: tmessage); var sender: ttitlebutton; tmp: boolean; begin tmp := fdown; fcallinheritedevent := true; sender := (tcomponent(msg.WParam) as ttitlebutton); if (sender <> self) and (msg.LParamLo = fgroupindex) then begin if tchangedproperty(msg.lparamhi) = cpdown then fdown := false; fallowallup := sender.fallowallup; if tmp <> fdown then invalidaterect(fparent.handle, @fbuttonrect, false); end; end; procedure TTitleButton.ParentMouseMove(var msg: tmessage); var pt: tpoint; tmppt: tpoint; tmprect: trect; tmpstate: Tshiftstate; begin fcallinheritedevent := true; if fvisible = false then exit; ffocused := false; pt.x := msg.lparamlo; pt.y := msg.lparamhi - fparent.top; tmppt := pt; tmppt.x := tmppt.x + 4; tmppt.y := 65536 - tmppt.y - fparent.top; tmprect := fbuttonrect; inflaterect(tmprect, 1, 1); if ptinrect(tmprect, tmppt) then begin ffocused := true; if assigned(fbuttonmove) then fbuttonmove(fparent, tmpstate, tmppt.x, tmppt.y); if (gtmp1 <> fpressed) or (gtmp2 <> ffocused) then // if fpressed then begin invalidaterect(fparent.handle, @fbuttonrect, false); gtmp1 := fpressed; gtmp2 := ffocused; end; end; if (gtmp1 <> fpressed) or (gtmp2 <> ffocused) then begin invalidaterect(fparent.handle, @fbuttonrect, false); gtmp1 := fpressed; gtmp2 := ffocused; end; fhintshow := false; fhint.releasehandle; end; procedure TTitleButton.ParentMouseUp(var msg: tmessage); var pt: tpoint; tmp: tpoint; tmprect: trect; tmpcallevent: boolean; begin fcallinheritedevent := true; if fvisible = false then exit; tmpcallevent := false; fhint.ReleaseHandle; fhintshow := true; ReleaseCapture; fpressed := false; pt.x := msg.lParamlo; pt.y := msg.lParamhi - fparent.top; tmp := pt; tmp.x := tmp.x + 4; tmp.y := 65536 - tmp.y; tmp.y := tmp.y - fparent.top; tmprect := fbuttonrect; inflaterect(tmprect, 0, 2); if tmp.y < (fparent.top + fparent.Height) then pt := tmp; if (ptinrect(tmprect, pt)) and (ffocused) and (gtmp3) then begin if fgroupindex <> 0 then begin if fallowallup = true then fdown := not (fdown) else fdown := true; gtmp3 := false; updateproperties(cpdown); if not (fdown) then tmpcallevent := true; end else tmpcallevent := true; parentpaint(fparent); if (tmpcallevent = true) and assigned(fbuttonup) then fbuttonup(fparent); end else gtmp3 := false; fcallinheritedevent := true; end; procedure TTitleButton.parentpaint(sender: tobject); var ButtonCanvas: TCanvas; textrect: trect; iconrect: trect; tmpwidth: integer; begin if fvisible = false then begin if assigned(ppaint) then ppaint(sender); exit; end; if not (csdesigning in componentstate) then begin if fwidth fwidth := fdefaultwidth; if fleft = 0 then fleft := fwidth + 1; fbuttonrect.left := fparent.width - fleft - (3 * fdefaultwidth) - (fborder3d + fborderthickness); fbuttonrect.right := fbuttonrect.left + fwidth; fbuttonrect.top := fborder3d + fborderthickness; fbuttonrect.bottom := fbuttonrect.top + fdefaultheight - (2 * fborder3d); ButtonCanvas := tcanvas.Create; ButtonCanvas.Handle := getwindowdc(fparent.handle); fillrect(buttoncanvas.Handle, fbuttonrect, HBRUSH(COLOR_BTNFACE + 1)); tmpwidth := fdefaultheight - 2; iconrect.left := fbuttonrect.left; iconrect.top := fbuttonrect.top; iconrect.right := iconrect.left + tmpwidth; iconrect.bottom := fbuttonrect.top + fdefaultheight - 2 * fborder3d; if ficon.handle <> 0 then subtractrect(textrect, fbuttonrect, iconrect) else textrect := fbuttonrect; if (ffocused and fpressed) or fdown then begin drawedge(ButtonCanvas.Handle, fbuttonrect, EDGE_SUNKEN, BF_SOFT or BF_RECT); textrect.left := textrect.left + 2; textrect.Top := textrect.Top + 1; textrect.right := textrect.right - 1; iconrect.left := iconrect.left + 3; iconrect.top := iconrect.top + 2; end; if (not (fpressed) or not (ffocused)) and not (fdown) then begin drawedge(ButtonCanvas.Handle, fbuttonrect, EDGE_RAISED, BF_SOFT or BF_RECT); textrect.left := textrect.left + 1; textrect.right := textrect.right - 1; iconrect.top := iconrect.top + 1; iconrect.left := iconrect.left + 2; end; ButtonCanvas.Brush.Style := bsclear; ButtonCanvas.Font.assign(ffont); if ficon.Handle <> 0 then begin drawiconex(buttoncanvas.handle, iconrect.left + 1, iconrect.top + 1, ficon.handle, tmpwidth - 5, fdefaultheight - 8, 0, 0, DI_NORMAL); if length(trim(fbuttoncaption)) > 0 then DrawTextEx(ButtonCanvas.Handle, PChar(fButtonCaption), Length(fbuttoncaption), textrect, DT_LEFT or DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_PATH_ELLIPSIS or DT_MODIFYSTRING, nil); end else DrawText(ButtonCanvas.Handle, PChar(fButtonCaption), Length(fbuttoncaption), textrect, DT_CENTER or DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_PATH_ELLIPSIS or DT_MODIFYSTRING); ButtonCanvas.Free; if assigned(ppaint) then ppaint(sender); end; end; procedure TTitleButton.parentresize(sender: tobject); begin fcallinheritedevent := true; if fvisible = false then begin if assigned(presize) then presize(sender); exit; end; parentpaint(sender); if assigned(presize) then presize(self); end; procedure TTitleButton.DisplaySettingChange(var msg: tmessage); begin fcallinheritedevent := true; if fvisible = false then exit; fdefaultwidth := GetSystemMetrics(SM_CXSIZE); if fwidth fwidth := fdefaultwidth; fdefaultheight := GetSystemMetrics(SM_CYSIZE); fborder3d := GetSystemMetrics(SM_CYEDGE); fborderthickness := GetSystemMetrics(SM_CYSIZEFRAME); parentpaint(fparent); msg.result := 0; end; procedure TTitleButton.setbuttonwidth(awidth: integer); begin if awidth > 0 then fwidth := awidth else fwidth := fdefaultwidth; parentpaint(fparent); end; procedure TTitleButton.setbuttonleft(aleft: integer); begin if (aleft fleft := aleft; parentpaint(fparent); end; procedure TTitleButton.setbuttoncaption(acaption: string); begin fbuttoncaption := acaption; parentpaint(fparent); end; procedure TTitleButton.setbuttonfont(afont: tfont); begin ffont.assign(afont); parentpaint(fparent); end; procedure TTitleButton.seticon(aicon: ticon); begin ficon.assign(aicon); parentpaint(fparent); end; procedure TTitleButton.setbuttonvisible(avisible: boolean); begin fvisible := avisible; fparent.perform(WM_NCACTIVATE, integer(true), 0); end; procedure TTitleButton.setdown(adown: boolean); var tmp: boolean; begin tmp := fdown; if csloading in componentstate then fdown := adown else begin if fdown <> adown then begin if fgroupindex = 0 then fdown := false else begin if fallowallup = true then fdown := adown else fdown := true; end; end; end; if tmp <> fdown then updateproperties(cpdown); end; procedure TTitleButton.setallowallup(aallowallup: boolean); var tmp: boolean; begin fcallinheritedevent := true; tmp := fallowallup; if csloading in componentstate then fallowallup := aallowallup else begin if fgroupindex <> 0 then fallowallup := aallowallup; if tmp <> fallowallup then updateproperties(cpallowallup); end; end; procedure TTitleButton.setgroupindex(agroupindex: integer); var tmp: integer; begin tmp := fgroupindex; if csloading in componentstate then fgroupindex := agroupindex else begin if agroupindex >= 65535 then agroupindex := 0; if (agroupindex >= 0) then fgroupindex := agroupindex; if fgroupindex = 0 then begin fallowallup := false; fdown := false; end; if tmp <> fgroupindex then updateproperties(cpgroupindex); end; end; procedure Register; begin RegisterComponents('Samples', [TTitleButton]); end; end. |