as ex-ex has changed the minimum point assignment to 50 points, it is nevermore comfortable for me to post 25 points qows (even i would more like it to do qows than qom.
qom -> question of the month
qom is a more difficult quest with following rules
- the first working solution gets this 100 pts
- each different working solution gets 50 pts in a seperate q
- top 15 experts are not allowed to participate in this quest, but they may post suggestions/hints
- top 15 experts may post a solution after the q is graded
- sponsoring, each one can sponsor this quest, by supplying the seperate q's for differnet solutions rather than me
- sponsors cannot participate on this quest
- a qom is one week open (on demand also longer)
- a qom starts on the first monday of a new month
well, the question now (is based on a paq from mine)
i need a speedbutton-component,
where i can link a same instance on it
a sample
let say i have 4 such buttons dropped on a form
if i press the third
-button1 going down and fires its onclick event
-button2 going down and fires its onclick event
-button3 going down and fires its onclick event
if i press the second
-button1 going down and fires its onclick event
-button2 going down and fires its onclick event
if i press the fourth
-button1 going down and fires its onclick event
-button2 going down and fires its onclick event
-button3 going down and fires its onclick event
-button4 going down and fires its onclick event
the logic should be implemented in the speedbutton-
component by properties
type
TForm1 = class(TForm)
procedure lbClick1(Sender: TObject);
procedure lbClick2(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMySpeedButton = class(TSpeedButton)
private
FLinkedButton: TMySpeedButton;
procedure SetLinkedButton(Value: TMySpeedButton);
function GetLinkedButton: TMySpeedButton;
public
procedure Click; override;
published
property LinkedButton: TMySpeedButton read GetLinkedButton write SetLinkedButton default nil;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// TMySpeedButton
procedure TMySpeedButton.Click;
var
LinkedButton: TMySpeedButton;
begin
LinkedButton := GetLinkedButton;
if LinkedButton <> nil then LinkedButton.Click;
inherited Click;
end;
procedure TMySpeedButton.SetLinkedButton(Value: TMySpeedButton);
begin
FLinkedButton := Value;
end;
function TMySpeedButton.GetLinkedButton: TMySpeedButton;
begin
result := FLinkedButton;
end;
// end of TMySpeedButton
procedure TForm1.lbClick1(Sender: TObject);
begin
ShowMessage('Button 1');
end;
procedure TForm1.lbClick2(Sender: TObject);
begin
ShowMessage('Button 2');
end;
procedure TForm1.FormCreate(Sender: TObject);
var
lb1,lb2: TMySpeedButton;
begin
// create two buttons
lb1 := TMySpeedButton.Create(Form1);
with lb1 do begin
Parent := Form1;
Left := 50;
Top := 20;
OnClick := lbClick1;
end;
lb2 := TMySpeedButton.Create(Form1);
with lb2 do begin
Parent := Form1;
Left := 100;
Top := 20;
OnClick := lbClick2;
LinkedButton := lb1; // First button lb1 is linked to the second one
end;
end;
procedure TMouseImage.WMMouseEnter(var Msg: TWMMouse);
var
P: TControl;
begin
inherited;
P := Self;
repeat
P := P.Parent;
until (P = nil) or (P is TForm);
if (P = nil) or TForm(P).Active then
begin
Entered := True;
if Assigned(FOnMouseEnter) then
FOnMouseEnter(Msg);
end;
end;
procedure TMouseImage.WMMouseLeave(var Msg: TWMMouse);
var
P: TControl;
begin
inherited;
P := Self;
repeat
P := P.Parent;
until (P = nil) or (P is TForm);
if (P = nil) or TForm(P).Active then
begin
Entered := False;
if Assigned(FOnMouseLeave) then
FOnMouseLeave(Msg);
end;
end;
procedure TMouseImage.CMHitTest(var Msg: TWMMouse);
begin
inherited;
if Assigned(PicUp) and Assigned(PicUp.Bitmap) and Transparent and
(Msg.XPos < PicUp.Bitmap.Width) and (Msg.YPos < PicUp.Bitmap.Height) and
(PicUp.Bitmap.Canvas.Pixels[Msg.XPos, Msg.YPos] = (Picture.Bitmap.TransparentColor and $FFFFFF)) then
Msg.Result := 0;
end;
procedure TMouseImage.SetEntered(Value: Boolean);
begin
FEntered := Value;
if Down or Entered then
Picture.Assign(PicDown)
else
Picture.Assign(PicUp);
end;
if i move the mouse over the third button a bevel is raised
now i want simultan that button1 and button2 also raises a bevel, like as the mousecursor are over there and of course if i move away the mouse from button3, the bevel disappears, also for button1 and button2
is it clear enough?
(i spend additional 100 pts,
if you or any other are providing a sample about this)
This is all easy ,its just that I use Borland c++builder(its the closest language to delphi) and would take me alot of time to convert c++builder code to delphi
Hi,
An additional property LinkedBevel is added. The task could be done without such property simply removing 'and LinkedBevel' from the two mouse message procedures.
procedure TMySpeedButton.Click;
begin
if Assigned(LinkedButton) then LinkedButton.Click;
inherited Click;
end;
procedure TMySpeedButton.SetLinkedButton(Value: TMySpeedButton);
begin
FLinkedButton := Value;
end;
procedure TMySpeedButton.WMMouseEnter(var Msg: TWMMouse);
begin
if Assigned(LinkedButton) and LinkedBevel then LinkedButton.WMMouseEnter(Msg);
inherited;
end;
procedure TMySpeedButton.WMMouseLeave(var Msg: TWMMouse);
begin
if Assigned(LinkedButton) and LinkedBevel then LinkedButton.WMMouseLeave(Msg);
inherited;
end;
// end of TMySpeedButton
procedure TForm1.lbClick1(Sender: TObject);
begin
ShowMessage('Button 1');
end;
procedure TForm1.lbClick2(Sender: TObject);
begin
ShowMessage('Button 2');
end;
procedure TForm1.lbClick3(Sender: TObject);
begin
ShowMessage('Button 3');
end;
procedure TForm1.FormCreate(Sender: TObject);
var
lb1,lb2,lb3: TMySpeedButton;
begin
// create three buttons
lb1 := TMySpeedButton.Create(Form1);
with lb1 do begin
Parent := Form1;
Left := 50;
Top := 20;
Flat := true;
Caption := '1';
OnClick := lbClick1;
LinkedBevel := true;
end;
lb2 := TMySpeedButton.Create(Form1);
with lb2 do begin
Parent := Form1;
Left := 100;
Top := 20;
Flat := true;
Caption := '2';
OnClick := lbClick2;
LinkedBevel := true;
LinkedButton := lb1; // First button lb1 is linked to the second one
end;
lb3 := TMySpeedButton.Create(Form1);
with lb3 do begin
Parent := Form1;
Left := 150;
Top := 20;
Flat := true;
Caption := '3';
OnClick := lbClick3;
LinkedBevel := true;
LinkedButton := lb2; // First button lb1 is linked to the second one
end;
end;
let say i have for buttons
if i click on the third button, i will have
button1-onclick-event fired
button2-onclick-event fired
button3-onclick-event fired
(initial question)
if i move with the mouse on the third button i will have
button1-bevel raised
button2-bevel raised
button3-bevel raised
(addon question)
well, this should also work,
if i leave the third-button->all bevels should disappear
and this all handled in one component,
derived from tspeedbutton
Good question, good idea about control's behaviour. I have an idea how this component can be used in real application. Something like selector of cumulative parameters settings.
>> - sponsoring, each one can sponsor this quest,
>> by supplying the seperate q's for differnet solutions rather than me
meikl, let me know if you are going to grade additional points for somebody.
-------
Igor
PS: it seems too easy, or you keep underwater rock? :-)
oh and I frogot to say the code is in delphi,But I develop with c++builder becuase it can compile c++ and delphi code ,but my main(the one I know best) language is c++ but I know delphi to ;-)
thats ok freshman,
don't hurry, you've time until next monday,
or on demand longer
yes, it should be a component,
but written with delphi source,
how you implement the component doesn't matter,
if u use a container or a collection or just
a derivement from tspeedbutton or any other
you are free with this, but at least there should be buttons with the bahaviour on a click-event as described
above (intial q)
and the beveling feature
(addon q, not a must, but gets additional 100 pts, for the first and 50 pts for each different solution)
don't forget to post the source, freshman
to all, good news,
after kpro did not properly work and my question points are not rounded up to 500, the moderator comTech pushed my question-points up to 5000, so that i'm able to grade each solution.
about sponsoring,
during finishing this thread next week,
i will post a list, who becomes how much pts in additional for ... q's. sponsors may pick up one or more from the list
and leave a comment which one was taken.
sponsors will then grade the taken expert(s)
with sponsors own q-points.
so far about sponsoring oragnisation
just a last word,
the component should be stable and recognize
run/designtime freed objects, which may linked to it
well, freshman,
you can send it to me
at my mailadress shown in my profile
(just click on my name)
but you have to post the source
in this thread for getting points,
just because its a knowledge-sharing community
and others than me may also interested on your solution
{--------------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('Samples', [TPSISpeedButton]);
end;
{--------------------------------------------------------------------------}
{ TPSISpeedButton }
{--------------------------------------------------------------------------}
function TPSISpeedButton.CheckOutTheChain(const Value: TSpeedButton): boolean;
var psisb: TSpeedButton;
begin
Result:=True;
//
if ((Value=NIL) or not (Value is TPSISpeedButton))
then EXIT;
//
psisb:=Value;
//
while ((psisb<>NIL) and (psisb is TPSISpeedButton)) do
begin
if psisb=Self
then
begin
Result:=False;
BREAK;
end;
//
psisb:=TPSISpeedButton(psisb).SB;
end;
end;
{--------------------------------------------------------------------------}
procedure TPSISpeedButton.Click;
begin
if FSB<>NIL
then FSB.Click;
//
INHERITED Click;
end;
{--------------------------------------------------------------------------}
procedure TPSISpeedButton.Notification(AComponent: TComponent;
Operation: TOperation);
begin
INHERITED Notification(AComponent, Operation);
//
if Operation=opRemove then
if AComponent=FSB then FSB:=NIL;
end;
{--------------------------------------------------------------------------}
procedure TPSISpeedButton.SetSB(const Value: TSpeedButton);
begin
if CheckOutTheChain(Value)
then FSB:=Value
else ShowMessage('You are not allowed to !');
end;
{--------------------------------------------------------------------------}
{--------------------------------------------------------------------------}
END.
1)you can link unlimited number of SpeedButtons together
2)Bevel raises on all buttons when go over with mouse
2)Bevel disappears on all buttons when leave button with mouse
3)OnClick event triggered on all buttons when click on button
constructor TSuperSpeedBtn.Create(AOwner: TComponent);
begin
FGlyph := TButtonGlyph.Create;
TButtonGlyph(FGlyph).OnChange := GlyphChanged;
inherited Create(AOwner);
SetBounds(0, 0, 23, 22);
ControlStyle := [csCaptureMouse, csDoubleClicks];
ParentFont := True;
Color := clBtnFace;
FSpacing := 4;
FMargin := -1;
FLayout := blGlyphLeft;
FTransparent := True;
FItems:=TStringList.Create;
FFlat:=True;
SendDataYN:=1;
Inc(ButtonCount);
end;
{----------}
destructor TSuperSpeedBtn.Destroy;
begin
Dec(ButtonCount);
inherited Destroy;
FItems.Free;
TButtonGlyph(FGlyph).Free;
end;
{----------}
procedure TSuperSpeedBtn.Paint;
const
DownStyles: array[Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);
FillStyles: array[Boolean] of Integer = (BF_MIDDLE, 0);
var
PaintRect: TRect;
DrawFlags: Integer;
Offset: TPoint;
begin
if not Enabled then
begin
FState := bsDisabled;
FDragging := False;
end
else if FState = bsDisabled then
if FDown and (GroupIndex <> 0) then
FState := bsExclusive
else
FState := bsUp;
Canvas.Font := Self.Font;
PaintRect := Rect(0, 0, Width, Height);
if not FFlat then
begin
DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if FState in [bsDown, bsExclusive] then
DrawFlags := DrawFlags or DFCS_PUSHED;
DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
end
else
begin
if (FState in [bsDown, bsExclusive]) or
(FMouseInControl and (FState <> bsDisabled)) or
(csDesigning in ComponentState) then
DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],
FillStyles[Transparent] or BF_RECT)
else if not Transparent then
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(PaintRect);
end;
InflateRect(PaintRect, -1, -1);
end;
if FState in [bsDown, bsExclusive] then
begin
if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
begin
Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
Canvas.FillRect(PaintRect);
end;
Offset.X := 1;
Offset.Y := 1;
end
else
begin
Offset.X := 0;
Offset.Y := 0;
end;
TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,FSpacing, FState, Transparent);
end;
{----------}
procedure TSuperSpeedBtn.UpdateTracking;
var
P: TPoint;
begin
if FFlat then
begin
if Enabled then
begin
GetCursorPos(P);
FMouseInControl := not (FindDragTarget(P, True) = Self);
if FMouseInControl then begin
Perform(CM_MOUSELEAVE, 0, 0);
end
else
Perform(CM_MOUSEENTER, 0, 0);
end;
end;
end;
{----------}
procedure TSuperSpeedBtn.UpdateTrack;
var
P: TPoint;
begin
GetCursorPos(P);
FMouseInControl2 := not (FindDragTarget(P, True) = Self);
end;
{----------}
procedure TSuperSpeedBtn.Loaded;
var
State: TButtonState;
begin
inherited Loaded;
if Enabled then
State := bsUp
else
State := bsDisabled;
TButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;
{----------}
procedure TSuperSpeedBtn.SendProc(msg : Integer);
var
I: Integer;
Compon: TControl;
begin
if (SendDataYN = 1) and (FItems.Count <> 0) then begin
for I := 0 to FItems.Count-1 do begin
Compon:=TControl(GetParentForm(self).FindComponent(Trim(FItems.Strings[I])));
if (Compon <> Self) and (Compon is TSuperSpeedBtn) then begin
SendData(msg,Compon);
end;
end;
end;
SendDataYN:=1;
end;
{----------}
procedure TSuperSpeedBtn.MouseDownProc;
begin
if not FDown then begin
FState := bsDown;
Invalidate;
FDragging := True;
SendProc(1);
end;
end;
{-----------}
procedure TSuperSpeedBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if (Button = mbLeft) and Enabled then begin
MouseDownProc;
end;
end;
{----------}
procedure TSuperSpeedBtn.MouseMoveProc(X, Y: Integer);
var
NewState: TButtonState;
begin
inherited MouseMove(df, X, Y);
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then begin
SendProc(3);
end;
if FDragging then begin
if not FDown then
NewState := bsUp
else
NewState := bsExclusive;
if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
if FDown then
NewState := bsExclusive
else
NewState := bsDown;
if NewState <> FState then
begin
FState := NewState;
if SendDataYN = 0 then begin
if sw=1 then begin
NewState:=bsDown;
end;
if sw=2 then begin
NewState:=bsUp;
end;
end;
Invalidate;
if NewState=bsDown then begin
SendProc(6);
end;
if NewState=bsUp then begin
SendProc(7);
end;
end;
end
else if not FMouseInControl then
UpdateTracking;
end;
{----------}
procedure TSuperSpeedBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
MouseMoveProc(X,Y);
end;
{----------}
procedure TSuperSpeedBtn.MouseUpProc2;
begin
UpdateTrack;
if (SendDataYN=1) then begin
if not FMouseInControl2 then begin
SendProc(2);
end
else begin
SendProc(5);
end;
end;
end;
{----------}
procedure TSuperSpeedBtn.MouseUpProc( X, Y: Integer);
var
DoClick: Boolean;
begin
inherited MouseUp(mbLeft,df, X, Y);
if FDragging then
begin
FDragging := False;
DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
if FGroupIndex = 0 then
begin
FState := bsUp;
FMouseInControl := False;
if DoClick and not (FState in [bsExclusive, bsDown]) then
Invalidate;
MouseUpProc2;
end
else
if DoClick then
begin
SetDown(not FDown);
if FDown then Repaint;
MouseUpProc2;
end
else
begin
if FDown then FState := bsExclusive;
Repaint;
MouseUpProc2;
end;
if DoClick then
if (SendDataYN = 0) and (sw2=3) then begin
Click;
end;
if (SendDataYN = 1) and not FMouseInControl2 then begin
Click;
end;
UpdateTracking;
end;
end;
{----------}
procedure TSuperSpeedBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);
begin
MouseUpProc(X,Y);
end;
{----------}
procedure TSuperSpeedBtn.Click;
begin
inherited Click;
end;
{----------}
function TSuperSpeedBtn.GetPalette: HPALETTE;
begin
Result := Glyph.Palette;
end;
{----------}
function TSuperSpeedBtn.GetGlyph: TBitmap;
begin
Result := TButtonGlyph(FGlyph).Glyph;
end;
{----------}
procedure TSuperSpeedBtn.SetGlyph(Value: TBitmap);
begin
TButtonGlyph(FGlyph).Glyph := Value;
Invalidate;
end;
{----------}
function TSuperSpeedBtn.GetNumGlyphs: TNumGlyphs;
begin
Result := TButtonGlyph(FGlyph).NumGlyphs;
end;
{----------}
procedure TSuperSpeedBtn.SetNumGlyphs(Value: TNumGlyphs);
begin
if Value < 0 then Value := 1
else if Value > 4 then Value := 4;
if Value <> TButtonGlyph(FGlyph).NumGlyphs then
begin
TButtonGlyph(FGlyph).NumGlyphs := Value;
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.GlyphChanged(Sender: TObject);
begin
Invalidate;
end;
{----------}
procedure TSuperSpeedBtn.UpdateExclusive;
var
Msg: TMessage;
begin
if (FGroupIndex <> 0) and (Parent <> nil) then
begin
Msg.Msg := CM_BUTTONPRESSED;
Msg.WParam := FGroupIndex;
Msg.LParam := Longint(Self);
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
{----------}
procedure TSuperSpeedBtn.SetDown(Value: Boolean);
begin
if FGroupIndex = 0 then Value := False;
if Value <> FDown then
begin
if FDown and (not FAllowAllUp) then Exit;
FDown := Value;
if Value then
begin
if FState = bsUp then Invalidate;
FState := bsExclusive
end
else
begin
FState := bsUp;
Repaint;
end;
if Value then UpdateExclusive;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetFlat(Value: Boolean);
begin
if Value <> FFlat then
begin
FFlat := Value;
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetGroupIndex(Value: Integer);
begin
if FGroupIndex <> Value then
begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetLayout(Value: TButtonLayout);
begin
if FLayout <> Value then
begin
FLayout := Value;
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetMargin(Value: Integer);
begin
if (Value <> FMargin) and (Value >= -1) then
begin
FMargin := Value;
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetSpacing(Value: Integer);
begin
if Value <> FSpacing then
begin
FSpacing := Value;
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetTransparent(Value: Boolean);
begin
if Value <> FTransparent then
begin
FTransparent := Value;
if Value then
ControlStyle := ControlStyle - [csOpaque] else
ControlStyle := ControlStyle + [csOpaque];
Invalidate;
end;
end;
{----------}
procedure TSuperSpeedBtn.SetAllowAllUp(Value: Boolean);
begin
if FAllowAllUp <> Value then
begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;
{----------}
procedure TSuperSpeedBtn.WMLButtonDblClk(var Message: TWMLButtonDown);
begin
inherited;
if FDown then DblClick;
end;
{----------}
procedure TSuperSpeedBtn.CMEnabledChanged(var Message: TMessage);
const
NewState: array[Boolean] of TButtonState = (bsDisabled, bsUp);
begin
TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
UpdateTracking;
Repaint;
end;
{----------}
procedure TSuperSpeedBtn.CMButtonPressed(var Message: TMessage);
var
Sender: TSuperSpeedBtn;
begin
if Message.WParam = FGroupIndex then
begin
Sender := TSuperSpeedBtn(Message.LParam);
if Sender <> Self then
begin
if Sender.Down and FDown then
begin
FDown := False;
FState := bsUp;
Invalidate;
end;
FAllowAllUp := Sender.AllowAllUp;
end;
end;
end;
{----------}
procedure TSuperSpeedBtn.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and Enabled and Visible and
(Parent <> nil) and Parent.Showing then
begin
Click;
Result := 1;
end else
inherited;
end;
{----------}
procedure TSuperSpeedBtn.CMFontChanged(var Message: TMessage);
begin
Invalidate;
end;
procedure TSuperSpeedBtn.CMTextChanged(var Message: TMessage);
begin
Invalidate;
end;
{----------}
procedure TSuperSpeedBtn.CMSysColorChange(var Message: TMessage);
begin
with TButtonGlyph(FGlyph) do
begin
Invalidate;
CreateButtonGlyph(FState);
end;
end;
{----------}
procedure TSuperSpeedBtn.CMMouseEnter(var Message: TMessage);
begin
inherited;
if FFlat and not FMouseInControl and Enabled and (DragMode <> dmAutomatic) and (GetCapture = 0) then
begin
FMouseInControl := True;
Repaint;
SendProc(3);
end;
end;
{----------}
procedure TSuperSpeedBtn.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FFlat and FMouseInControl and Enabled and not FDragging then
begin
FMouseInControl := False;
Invalidate;
SendProc(4);
end;
end;
{----------}
procedure TSuperSpeedBtn.SetLinkList(aValue : TStrings);
begin
FItems.Assign(aValue);
end;
{----------}
Procedure TSuperSpeedBtn.WMCopyData( Var msg: TCopyDataStruct);
Var
st: String;
Begin
st:=PChar(msg.lpData);
SendDataYN:=0;
if st=IntToStr(1) then begin
if ((GetAsyncKeyState(VK_LBUTTON) < 0) = TRUE) and Enabled then begin
MouseDownProc;
end;
end;
if st=IntToStr(2) then begin
sw2:=3;
MouseUpProc(0,0);
end;
if st=IntToStr(3) then begin
Perform(CM_MOUSEENTER,0,0);
end;
if st=IntToStr(4) then begin
Perform(CM_MOUSELEAVE,0,0);
end;
if st=IntToStr(5) then begin
sw2:=4;
MouseUpProc(0,0);
end;
if st=IntToStr(6) then begin
sw:=1;
MouseMoveProc(0,0);
end;
if st=IntToStr(7) then begin
sw:=2;
MouseMoveProc(-1,-1);
end;
End;
{----------}
Procedure TSuperSpeedBtn.SendData(msg: Integer; comp: TControl);
var
S: String;
data: TCopyDataStruct;
begin
S:= IntToStr(msg);
data.dwData := DWORD(S[1]);
data.cbData := 2;
comp.Perform(WM_COPYDATA,0,integer(@data));
end;
{-----------}
procedure Register;
begin
RegisterComponents ('SuperBtn',[TSuperSpeedBtn]);
end;
var
BitBtnGlyphs: array[TBitBtnKind] of TBitmap;
MouseInBtn:TButton;
LeaveMsgSending:Boolean;
Pattern: TBitmap = nil;
ButtonCount: Integer = 0;
GlyphCache: TGlyphCache = nil;
implementation
{ DrawButtonFace - returns the remaining usable area inside the Client rect.}
function DrawButtonFace(Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
IsFocused: Boolean): TRect;
var
NewStyle: Boolean;
R: TRect;
DC: THandle;
begin
NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);
R := Client;
with Canvas do
begin
if NewStyle then
begin
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
DC := Canvas.Handle; { Reduce calls to GetHandle }
if IsDown then
begin { DrawEdge is faster than Polyline }
DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); { black }
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); { btnhilite }
Dec(R.Bottom);
Dec(R.Right);
Inc(R.Top);
Inc(R.Left);
DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); { btnshadow }
end
else
begin
DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); { black }
Dec(R.Bottom);
Dec(R.Right);
DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); { btnhilite }
Inc(R.Top);
Inc(R.Left);
DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); { btnshadow }
end;
end
else
begin
Pen.Color := clWindowFrame;
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
{ round the corners - only applies to Win 3.1 style buttons }
if IsRounded then
begin
Pixels[R.Left, R.Top] := clBtnFace;
Pixels[R.Left, R.Bottom - 1] := clBtnFace;
Pixels[R.Right - 1, R.Top] := clBtnFace;
Pixels[R.Right - 1, R.Bottom - 1] := clBtnFace;
end;
if IsFocused then
begin
InflateRect(R, -1, -1);
Brush.Style := bsClear;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;
InflateRect(R, -1, -1);
if not IsDown then
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, BevelWidth)
else
begin
Pen.Color := clBtnShadow;
PolyLine([Point(R.Left, R.Bottom - 1), Point(R.Left, R.Top),
Point(R.Right, R.Top)]);
end;
end;
end;
Result := Rect(Client.Left + 1, Client.Top + 1,
Client.Right - 2, Client.Bottom - 2);
if IsDown then OffsetRect(Result, 1, 1);
end;
function GetBitBtnGlyph(Kind: TBitBtnKind): TBitmap;
begin
if BitBtnGlyphs[Kind] = nil then
begin
BitBtnGlyphs[Kind] := TBitmap.Create;
BitBtnGlyphs[Kind].Handle := LoadBitmap(HInstance, BitBtnResNames[Kind]);
end;
Result := BitBtnGlyphs[Kind];
end;
{ TGlyphList }
constructor TGlyphList.Create(AWidth, AHeight: Integer);
begin
inherited CreateSize(AWidth, AHeight);
Used := TBits.Create;
end;
destructor TGlyphList.Destroy;
begin
Used.Free;
inherited Destroy;
end;
function TGlyphList.AllocateIndex: Integer;
begin
Result := Used.OpenBit;
if Result >= Used.Size then
begin
Result := inherited Add(nil, nil);
Used.Size := Result + 1;
end;
Used[Result] := True;
end;
function TGlyphList.Add(Image, Mask: TBitmap): Integer;
begin
Result := AllocateIndex;
Replace(Result, Image, Mask);
Inc(FCount);
end;
function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;
begin
Result := AllocateIndex;
ReplaceMasked(Result, Image, MaskColor);
Inc(FCount);
end;
procedure TGlyphList.Delete(Index: Integer);
begin
if Used[Index] then
begin
Dec(FCount);
Used[Index] := False;
end;
end;
{ TGlyphCache }
constructor TGlyphCache.Create;
begin
inherited Create;
GlyphLists := TList.Create;
end;
destructor TGlyphCache.Destroy;
begin
GlyphLists.Free;
inherited Destroy;
end;
function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;
var
I: Integer;
begin
for I := GlyphLists.Count - 1 downto 0 do
begin
Result := GlyphLists[I];
with Result do
if (AWidth = Width) and (AHeight = Height) then Exit;
end;
Result := TGlyphList.Create(AWidth, AHeight);
GlyphLists.Add(Result);
end;
procedure TGlyphCache.ReturnList(List: TGlyphList);
begin
if List = nil then Exit;
if List.Count = 0 then
begin
GlyphLists.Remove(List);
List.Free;
end;
end;
function TGlyphCache.Empty: Boolean;
begin
Result := GlyphLists.Count = 0;
end;
procedure CreateBrushPattern;
var
X, Y: Integer;
begin
Pattern := TBitmap.Create;
Pattern.Width := 8;
Pattern.Height := 8;
with Pattern.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clBtnFace;
FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));
for Y := 0 to 7 do
for X := 0 to 7 do
if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }
Pixels[X, Y] := clWhite; { on even/odd rows }
end;
end;
{ TButtonGlyph }
constructor TButtonGlyph.Create;
var
I: TButtonState;
begin
inherited Create;
FOriginal := TBitmap.Create;
FOriginal.OnChange := GlyphChanged;
FTransparentColor := clOlive;
FNumGlyphs := 1;
for I := Low(I) to High(I) do
FIndexs[I] := -1;
if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
end;
destructor TButtonGlyph.Destroy;
begin
FOriginal.Free;
Invalidate;
if Assigned(GlyphCache) and GlyphCache.Empty then
begin
GlyphCache.Free;
GlyphCache := nil;
end;
inherited Destroy;
end;
procedure TButtonGlyph.Invalidate;
var
I: TButtonState;
begin
for I := Low(I) to High(I) do
begin
if FIndexs[I] <> -1 then FGlyphList.Delete(FIndexs[I]);
FIndexs[I] := -1;
end;
GlyphCache.ReturnList(FGlyphList);
FGlyphList := nil;
end;
procedure TButtonGlyph.GlyphChanged(Sender: TObject);
begin
if Sender = FOriginal then
begin
FTransparentColor := FOriginal.TransparentColor;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TButtonGlyph.SetGlyph(Value: TBitmap);
var
Glyphs: Integer;
begin
Invalidate;
FOriginal.Assign(Value);
if (Value <> nil) and (Value.Height > 0) then
begin
FTransparentColor := Value.TransparentColor;
if Value.Width mod Value.Height = 0 then
begin
Glyphs := Value.Width div Value.Height;
if Glyphs > 4 then Glyphs := 1;
SetNumGlyphs(Glyphs);
end;
end;
end;
procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);
begin
if (Value <> FNumGlyphs) and (Value > 0) then
begin
Invalidate;
FNumGlyphs := Value;
GlyphChanged(Glyph);
end;
end;
function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;
const
ROP_DSPDxax = $00E20746;
var
TmpImage, DDB, MonoBmp: TBitmap;
IWidth, IHeight: Integer;
IRect, ORect: TRect;
I: TButtonState;
DestDC: HDC;
begin
if (State = bsDown) and (NumGlyphs < 3) then State := bsUp;
Result := FIndexs[State];
if Result <> -1 then Exit;
if (FOriginal.Width or FOriginal.Height) = 0 then Exit;
IWidth := FOriginal.Width div FNumGlyphs;
IHeight := FOriginal.Height;
if FGlyphList = nil then
begin
if GlyphCache = nil then GlyphCache := TGlyphCache.Create;
FGlyphList := GlyphCache.GetList(IWidth, IHeight);
end;
TmpImage := TBitmap.Create;
try
TmpImage.Width := IWidth;
TmpImage.Height := IHeight;
IRect := Rect(0, 0, IWidth, IHeight);
TmpImage.Canvas.Brush.Color := clBtnFace;
TmpImage.Palette := CopyPalette(FOriginal.Palette);
I := State;
if Ord(I) >= NumGlyphs then I := bsUp;
ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);
case State of
bsUp, bsDown,
bsExclusive:
begin
TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);
if FOriginal.TransparentMode = tmFixed then
FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)
else
FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
end;
bsDisabled:
begin
MonoBmp := nil;
DDB := nil;
try
MonoBmp := TBitmap.Create;
DDB := TBitmap.Create;
DDB.Assign(FOriginal);
DDB.HandleType := bmDDB;
if NumGlyphs > 1 then
with TmpImage.Canvas do
begin { Change white & gray to clBtnHighlight and clBtnShadow }
CopyRect(IRect, DDB.Canvas, ORect);
MonoBmp.Monochrome := True;
MonoBmp.Width := IWidth;
MonoBmp.Height := IHeight;
{ Convert transparent color to clBtnFace }
DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);
MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);
Brush.Color := clBtnFace;
DestDC := Handle;
SetTextColor(DestDC, clBlack);
SetBkColor(DestDC, clWhite);
BitBlt(DestDC, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end
else
begin
{ Create a disabled version }
with MonoBmp do
begin
Assign(FOriginal);
HandleType := bmDDB;
Canvas.Brush.Color := clBlack;
Width := IWidth;
if Monochrome then
begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with TmpImage.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBtnHighlight;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 1, 1, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
Brush.Color := clBtnShadow;
SetTextColor(Handle, clBlack);
SetBkColor(Handle, clWhite);
BitBlt(Handle, 0, 0, IWidth, IHeight,
MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
end;
end;
finally
DDB.Free;
MonoBmp.Free;
end;
FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);
end;
end;
finally
TmpImage.Free;
end;
Result := FIndexs[State];
FOriginal.Dormant;
end;
procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;
State: TButtonState; Transparent: Boolean);
var
Index: Integer;
begin
if FOriginal = nil then Exit;
if (FOriginal.Width = 0) or (FOriginal.Height = 0) then Exit;
Index := CreateButtonGlyph(State);
with GlyphPos do
if Transparent or (State = bsExclusive) then
ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
clNone, clNone, ILD_Transparent)
else
ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,
ColorToRGB(clBtnFace), clNone, ILD_Normal);
end;
procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;
TextBounds: TRect; State: TButtonState);
begin
with Canvas do
begin
Brush.Style := bsClear;
if State = bsDisabled then
begin
OffsetRect(TextBounds, 1, 1);
Font.Color := clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
OffsetRect(TextBounds, -1, -1);
Font.Color := clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds, 0);
end else
DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
end;
procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect);
var
TextPos: TPoint;
ClientSize, GlyphSize, TextSize: TPoint;
TotalSize: TPoint;
begin
{ calculate the item sizes }
ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
Client.Top);
if FOriginal <> nil then
GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height) else
GlyphSize := Point(0, 0);
if Length(Caption) > 0 then
begin
TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_CALCRECT);
TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
TextBounds.Top);
end
else
begin
TextBounds := Rect(0, 0, 0, 0);
TextSize := Point(0,0);
end;
{ If the layout has the glyph on the right or the left, then both the
text and the glyph are centered vertically. If the glyph is on the top
or the bottom, then both the text and the glyph are centered horizontally.}
if Layout in [blGlyphLeft, blGlyphRight] then
begin
GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
end
else
begin
GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
end;
{ if there is no text or no bitmap, then Spacing is irrelevant }
if (TextSize.X = 0) or (GlyphSize.X = 0) then
Spacing := 0;
{ adjust Margin and Spacing }
if Margin = -1 then
begin
if Spacing = -1 then
begin
TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
if Layout in [blGlyphLeft, blGlyphRight] then
Margin := (ClientSize.X - TotalSize.X) div 3
else
Margin := (ClientSize.Y - TotalSize.Y) div 3;
Spacing := Margin;
end
else
begin
TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
Spacing + TextSize.Y);
if Layout in [blGlyphLeft, blGlyphRight] then
Margin := (ClientSize.X - TotalSize.X + 1) div 2
else
Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
end;
end
else
begin
if Spacing = -1 then
begin
TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
(Margin + GlyphSize.Y));
if Layout in [blGlyphLeft, blGlyphRight] then
Spacing := (TotalSize.X - TextSize.X) div 2
else
Spacing := (TotalSize.Y - TextSize.Y) div 2;
end;
end;
would be nice, freshman,
then it would be not to hard for me
to evaluate,
but in your case i have the exe and
i trust you that your exe is based on your source,
so that it is not a must for you to explain it for me
but others may know this
in some hours,
the results are posted
(first i must be a little bit for my family,
because i'm a short time at home todays evening)
>i trust you that your exe is based on your source
yes, exe I gave you is already using the component
>first i must be a little bit for my family,because i'm a
>short time at home todays evening
of course,after all your family is far more important then this q
>i trust you that your exe is based on your source
yes, exe I gave you is already using the component
>first i must be a little bit for my family,because i'm a
>short time at home todays evening
of course,after all your family is far more important then this q
for example I have four of these buttons placed on the form and I want that all of these buttons to control each other, I would set there linkwith property as follows:
SuperSpeedBtn1's linkwith property would be:
SuperSpeedBtn2
SuperSpeedBtn3
SuperSpeedBtn4
SuperSpeedBtn2's linkwith property would be:
SuperSpeedBtn1
SuperSpeedBtn3
SuperSpeedBtn4
SuperSpeedBtn3's linkwith property would be:
SuperSpeedBtn1
SuperSpeedBtn2
SuperSpeedBtn4
SuperSpeedBtn4's linkwith property would be:
SuperSpeedBtn1
SuperSpeedBtn2
SuperSpeedBtn3
Hope thats clear enought
P.S: if you want ,I can change the component so you dont have to type into each button separately but instead type everything into just one button
geobul:
100 pts for first on basic question
100 pts for first addon question
(i will raise this q up to 200 and grade you, geo)
robert:
failed the goal of this question,
but for providing an interest component,
which shows how to handle messages for the addon q
50 pts in a separat question
nestorua:
50 pts for solving basic question (but not first)
25 pts for qow17, which i have not gave you yet
freshmen:
50 pts for solving basic question (but not first)
50 pts for solving addon question (but not first)
50 pts for best implementation (bonus)
summary:
geobul : 200 pts with this q
robert : 50 pts in a separate q
nestorua : 75 pts in a separate q
freshmen : 150 pts in a separate q
if all agree, then i will close this thread in two days
from now, otherwise just tell me
sponsors may pick within this two days one or more
experts, which are get its points in a separate q
freshmen,
>meikl , Should I tell how to use the component? :-)
yes
No offense but all of Geobul's solutions are hard coded so you cannot link multiple buttons together and that dosent answer the basic question and addon question
>freshmen,
>>meikl , Should I tell how to use the component? :-)
>yes
I already posted how to use the component in my last post
No offense but all of Geobul's solutions are hard coded so you cannot link multiple buttons together and that dosent answer the basic question and addon question
>freshmen,
>>meikl , Should I tell how to use the component? :-)
>yes
I already posted how to use the component in my last post
:-))
sorry, freshman, as i wrote my last comment,
i didn't saw your last comment ;-)
about geobuls solution,
i guessed it would be not too hard
to extract the TMySpeedButton-Class parts
into a unit and add a register-procedure,
but well, your criticism is correct
1)hard coded so you cannot link multiple buttons together.
and this by itself automatically dosent answer the basic question and the addon question
2)
>if i press the third
>-button1 going down and fires its onclick event
>-button2 going down and fires its onclick event
>-button3 going down and fires its onclick event....
As you asked as an addon question the button to go down ,Geobul's solution doesnt make the button go down,
and this itself dosent answer the addon question either
and Here is what I think about nestorua's solutions:
1)same as Geobul's
and Here is what I think about robert's solutions:
1)robert failed the goal of this question
P.S: to everyone: No hard fellings,I'am just being fair
:-)
procedure TMySpeedButton.Click;
begin
if Assigned(LinkedButton) then LinkedButton.Click;
inherited Click;
end;
procedure TMySpeedButton.SetLinkedButton(Value: TMySpeedButton);
begin
FLinkedButton := Value;
end;
procedure TMySpeedButton.WMMouseEnter(var Msg: TWMMouse);
begin
if Assigned(LinkedButton) and LinkedBevel then LinkedButton.WMMouseEnter(Msg);
inherited;
end;
procedure TMySpeedButton.WMMouseLeave(var Msg: TWMMouse);
begin
if Assigned(LinkedButton) and LinkedBevel then LinkedButton.WMMouseLeave(Msg);
inherited;
end;
end.
now you've a component, where you can link at designtime
buttons with the same class
to 2.
good point, missed this myself
(sometimes i should reread my own questions) :-))
to 3(1). nestoruas is near exact to geobuls, but provides the notification-procedure and implements a check for avoiding circular links
to 4(1). as stated robert failed the goal
well,
what is the meaning of the others,
as freshman is correct about his objectives as it is
geo solves the question not in all cases
robert failed
nestorua just "expands" geos solution
freshman matches the question exact and a bit more
freshman,
how should the gradings shown,
from your point of view?
well,
your suggestion seems to be ok for me,
except for geobul 2x 75 pts (was both first, but results is the same)
except for nestorua (was not first) i would give 45 pts,
what about yourself,
atleast you solved all,
i would keep the 150 pts grade for you, freshman
after discussion following gradings
geobul 150
nestorua 45 +(25 from qow17) = 70
robert 30
freshman 150 (or 200 for complete genius solution?)
Something like (tested with run-time creation only):
-----
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls;
type
TForm1 = class(TForm)
procedure lbClick1(Sender: TObject);
procedure lbClick2(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMySpeedButton = class(TSpeedButton)
private
FLinkedButton: TMySpeedButton;
procedure SetLinkedButton(Value: TMySpeedButton);
function GetLinkedButton: TMySpeedButton;
public
procedure Click; override;
published
property LinkedButton: TMySpeedButton read GetLinkedButton write SetLinkedButton default nil;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// TMySpeedButton
procedure TMySpeedButton.Click;
var
LinkedButton: TMySpeedButton;
begin
LinkedButton := GetLinkedButton;
if LinkedButton <> nil then LinkedButton.Click;
inherited Click;
end;
procedure TMySpeedButton.SetLinkedBu
begin
FLinkedButton := Value;
end;
function TMySpeedButton.GetLinkedBu
begin
result := FLinkedButton;
end;
// end of TMySpeedButton
procedure TForm1.lbClick1(Sender: TObject);
begin
ShowMessage('Button 1');
end;
procedure TForm1.lbClick2(Sender: TObject);
begin
ShowMessage('Button 2');
end;
procedure TForm1.FormCreate(Sender: TObject);
var
lb1,lb2: TMySpeedButton;
begin
// create two buttons
lb1 := TMySpeedButton.Create(Form
with lb1 do begin
Parent := Form1;
Left := 50;
Top := 20;
OnClick := lbClick1;
end;
lb2 := TMySpeedButton.Create(Form
with lb2 do begin
Parent := Form1;
Left := 100;
Top := 20;
OnClick := lbClick2;
LinkedButton := lb1; // First button lb1 is linked to the second one
end;
end;
end.
-----
Regards, Geo