Mega Code Archive
Create a control like the `open icon` present in the speed bar of Delphi 3
<![CDATA[
Title: Create a control like the `open icon` present in the speed bar of Delphi 3
Question: Have you seen open button on the toolbar of Delphi 3. When you click on one part of the icon the open dialog box is displayed. when you click on the other part a list of recent files are shown. How can you create such a control in Delphi?
Answer:
Have you seen open button on the toolbar of Delphi 3. When you click on one part of the icon the open dialog box is displayed. when you click on the other part a list of recent files are shown. How can you create such a control in Delphi?
I have totally changed the previous component that I had created.
Now I have created a component called TDoubleButton derived from the Tgraphiccontrol.
I have added these properties.
Picture1: used for showing the bitmap of first button.
Picture2: used for showing the bitmap of second button.
Picture1left and Picture1top: usedfor positioning the bitmap in the firstbutton
Picture2left and Picture2top: used for positioning the bitmap in the second button
SelectedButton: If the first button is clicked selectedbutton has value 0. and If the second button is clicked selectedbutton has the value 1.
The new control has the same flat look as the button found in Delphi3 as well as the 'back' button found in Internet Explorer 5.0.
In the mousedown event handler you can findout which button was pushed and perform a function accordingly.
here is the updated code.
The code is also much smaller.
unit DoubleButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,ExtCtrls, CommCtrl;
type
Tbuttonstate=(bsfocused,bsup1,bsup2,bsdown1,bsdown2,bsnull);
TDoubleButton = class(TGraphicControl)
private
{ Private declarations }
protected
splitpos:integer;
selbutton:integer;
rec1,rec2,rec3:trect;
Fstate:Tbuttonstate;
bdown1,bdown2:boolean;
pic1,pic2:tbitmap;
picpos1,picpos2:tpoint;
procedure CMMouseEnter(var msg:Tmessage);message CM_MOUSEENTER;
procedure CMMouseLeave(var msg:Tmessage);message CM_MOUSELEAVE;
procedure CMHitTest(var msg:Tmessage);message WM_NCHITTEST;
procedure MouseDown(Button:TMouseButton ; Shift:TShiftState; X,Y:Integer);override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
procedure MouseUp(Button:TMouseButton ; Shift:TShiftState; X,Y:Integer);override;
procedure paint;override;
procedure setsplitpos(asplitpos:integer);
procedure setpic1(apic:tbitmap);
procedure setpic2(apic:tbitmap);
procedure setpicpos1left(apicleft:integer);
procedure setpicpos1top(apictop:integer);
procedure setpicpos2left(apicleft:integer);
procedure setpicpos2top(apictop:integer);
public
procedure setbounds(left:integer;top:integer;width:integer;height:integer);override;
procedure loaded;override;
constructor create(aowner:tcomponent);override;
property SelectedButton:integer read selbutton;
published
property SplitPosition:integer read splitpos write setsplitpos;
property Picture1:TBitmap read pic1 write setpic1;
property Picture2:TBitmap read pic2 write setpic2;
property Picture1Left:integer read picpos1.x write setpicpos1left;
property Picture1Top:integer read picpos1.y write setpicpos1top;
property Picture2Left:integer read picpos2.x write setpicpos2left;
property Picture2Top:integer read picpos2.y write setpicpos2top;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnClick;
end;
procedure Register;
implementation
constructor TdoubleButton.create(aowner:tcomponent);
begin
inherited;
pic1:=TBitmap.create;
pic2:=TBitmap.create;
pic1.TransparentColor:=clOlive;
pic1.Transparent:=true;
pic2.TransparentColor:=clOlive;
pic2.Transparent:=true;
fstate:=bsnull;
bdown1:=false;
bdown2:=false;
end;
procedure TdoubleButton.setpicpos1left(apicleft:integer);
begin
if (apicleft=0) then
picpos1.x:=apicleft;
invalidate;
end;
procedure TdoubleButton.setpicpos1top(apictop:integer);
begin
if (apictop)=0 then
picpos1.y:=apictop;
invalidate;
end;
procedure TdoubleButton.setpicpos2left(apicleft:integer);
begin
if (apicleft=0) then
picpos2.x:=apicleft;
invalidate;
end;
procedure TdoubleButton.setpicpos2top(apictop:integer);
begin
if (apictop)=0 then
picpos2.y:=apictop;
invalidate;
end;
procedure TdoubleButton.setpic1(apic:tbitmap);
begin
pic1.Assign(apic);
end;
procedure TdoubleButton.setpic2(apic:tbitmap);
begin
pic2.Assign(apic);
end;
procedure TdoubleButton.loaded;
begin
inherited;
end;
procedure TdoubleButton.CMHitTest(var msg:Tmessage);
var
pt1:tpoint;
begin
inherited;
pt1.x:=msg.LParamLo;
pt1.y:=msg.LParamHi;
if (ptinrect(rec1,pt1))=false then
begin
fstate:=bsnull;
invalidate;
end;
end;
procedure TdoubleButton.MouseUp(Button:TMouseButton ; Shift:TShiftState; X,Y:Integer);
var
pt:tpoint;
begin
if not(csdesigning in componentstate) then
begin
pt.x:=x;
pt.y:=y;
if (ptinrect(rec2,pt)) and (button=mbleft) then
begin
fstate:=bsup1;
bdown1:=false;
if bdown2=true then
bdown2:=false;
end
else if ptinrect(rec3,pt) and (button=mbleft) then
begin
fstate:=bsup2;
bdown2:=false;
end;
invalidate;
end;
inherited;
end;
procedure TDoubleButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
pt:tpoint;
begin
pt.x:=x;
pt.y:=y;
if ptinrect(rec2,pt) then
selbutton:=0
else if ptinrect(rec3,pt) then
selbutton:=1;
end;
procedure TdoubleButton.MouseDown(Button:TMouseButton ; Shift:TShiftState; X,Y:Integer);
var
pt:tpoint;
begin
if not(csdesigning in componentstate) then
begin
pt.x:=x;
pt.y:=y;
if (ptinrect(rec2,pt)) and (button=mbleft) then
begin
if Fstate=bsdown2 then
selbutton:=-1
else
selbutton:=0;
fstate:=bsdown1;
bdown1:=true;
end
else if ptinrect(rec3,pt) and (button=mbleft) then
begin
if Fstate=bsdown2 then
begin
selbutton:=-1;
fstate:=bsup2;
bdown2:=false;
end
else
begin
selbutton:=1;
fstate:=bsdown2;
bdown2:=true;
end;
end;
invalidate;
end;
inherited;
end;
procedure TdoubleButton.setsplitpos(asplitpos:integer);
begin
if (asplitpos0) and (asplitpos begin
splitpos:=asplitpos;
rec2.left:=clientrect.left;
rec2.top:=clientrect.top;
rec2.Right:=clientrect.left+splitpos;
rec2.Bottom:=clientrect.top+height;
rec3.left:=clientrect.left+splitpos;
rec3.top:=clientrect.top;
rec3.Right:=clientrect.left+width;
rec3.Bottom:=clientrect.top+height;
invalidate;
end;
end;
procedure TdoubleButton.setbounds(left:integer;top:integer;width:integer;height:integer);
begin
inherited;
rec1.Left:=clientrect.left;
rec1.top:=clientrect.top;
rec1.Right:=clientrect.left+width;
rec1.Bottom:=clientrect.top+height;
rec2.left:=clientrect.left;
rec2.top:=clientrect.top;
rec2.Right:=clientrect.left+splitpos;
rec2.Bottom:=clientrect.top+height;
rec3.left:=clientrect.left+splitpos;
rec3.top:=clientrect.top;
rec3.Right:=clientrect.left+width;
rec3.Bottom:=clientrect.top+height;
end;
procedure Tdoublebutton.paint;
var
DC:integer;
tmprec:trect;
begin
inherited;
canvas.Brush.Style:=bssolid;
canvas.Brush.color:=clBtnFace;
DC:=canvas.Handle;
pic1.TransparentColor:=pic1.canvas.Pixels[0,0];
pic1.Transparent:=true;
pic2.TransparentColor:=pic2.canvas.Pixels[0,0];
pic2.Transparent:=true;
if pic1.height(rec2.Bottom-rec2.top) then
pic1.Height:=(rec2.Bottom-rec2.top);
if pic1.Width(rec2.right-rec2.left) then
pic1.Width:=(rec2.right-rec2.left);
if pic2.height(rec3.Bottom-rec3.top) then
pic2.Height:=(rec3.Bottom-rec3.top);
if pic2.Width(rec3.right-rec3.left) then
pic2.Width:=(rec3.right-rec3.left);
canvas.Draw(rec2.left+picpos1.x ,rec2.top+picpos1.y,pic1);
canvas.Draw(rec3.left+picpos2.x,rec3.top+picpos2.y,pic2);
if (csdesigning in componentstate) then
begin
tmprec:=rec2;
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
dec(tmprec.Bottom);
dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_TOPLEFT);
tmprec:=rec3;
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
Dec(tmprec.Bottom);
Dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_TOPLEFT);
end;
if not(csdesigning in componentstate) then
begin
if (fstate=bsfocused)or (fstate=bsup1)or (fstate=bsup2) or((fstate=bsdown1) and (bdown2=true)) then
begin
tmprec:=rec2;
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
dec(tmprec.Bottom);
dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_TOPLEFT);
tmprec:=rec3;
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
Dec(tmprec.Bottom);
Dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_TOPLEFT);
//canvas.StretchDraw(rec2,pic1);
end
else if (fstate=bsdown1) and (bdown2=false) then
begin
tmprec:=rec2;
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_BOTTOMRIGHT or BF_SOFT);
dec(tmprec.Bottom);
dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_TOPLEFT or BF_SOFT);
tmprec:=rec3;
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_BOTTOMRIGHT or BF_SOFT);
Dec(tmprec.Bottom);
Dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_TOPLEFT or BF_SOFT);
end
else if(fstate=bsdown2) then
begin
tmprec:=rec2;
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
dec(tmprec.Bottom);
dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_RAISEDINNER, BF_TOPLEFT);
tmprec:=rec3;
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_BOTTOMRIGHT or BF_SOFT);
Dec(tmprec.Bottom);
Dec(tmprec.Right);
DrawEdge(DC, tmprec, BDR_SUNKENINNER, BF_TOPLEFT or BF_SOFT);
end
else
begin
fstate:=bsnull;
bdown1:=false;
bdown2:=false;
end;
end;
end;
procedure TDoubleButton.CMMouseEnter(var msg:Tmessage);
begin
inherited;
Fstate:=bsfocused;
invalidate;
end;
procedure TDoubleButton.CMMouseLeave(var msg:Tmessage);
begin
fstate:=bsnull;
selbutton:=-1;
invalidate;
end;
procedure Register;
begin
RegisterComponents('Samples', [TDoubleButton]);
end;
copy the code into a pas file and register it by using Install Component.
Create the control and put it in a TCoolBar Component.
please tell me if you find any bugs.
]]>