Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 259
  • Last Modified:

i need two special components

The first one should be a TBitBtn descendant because it needs Focus, Glyph and Caption.
The trick is that a left click should only set focus to the control, but should not generate an OnClick event.

The second component should be a TImage where the OnClick is only fired when a non-transparent part of the image is clicked.

Best source code or links to free source code.
0
robert_marquardt
Asked:
robert_marquardt
  • 9
  • 8
  • 8
  • +1
1 Solution
 
kretzschmarCommented:
well not free

www.cooldev.com
0
 
ITugayCommented:
Hi robert_marquard.

meikl:-)

I think it should be something like this:

  TMyBitBtn = class(TBitBtn)
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  end;

  TMyImage = class(TImage)
  protected
    procedure WM_LBUTTONDOWN(var M: TMessage); message WM_LBUTTONDOWN;
  end;
.........
procedure TMyBitBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if CanFocus then
    SetFocus;
  Inherited;
end;


procedure TMyImage.WM_LBUTTONDOWN(var M: TMessage);
var
  B: TBitmap;
begin
  B := Picture.Bitmap;
  if B.Canvas.Pixels[LoWord(M.LParam), HiWord(M.LParam)] = (B.TransparentColor and $FFFFFF) then
    M.Result := 0
  else
    Inherited;
end;

-----
Igor
0
 
TOndrejCommented:
Hi,
here is a little test:

type
  TSpecialBitBtn = class(TBitBtn)
  protected
    procedure Click; override;
  end;

procedure TSpecialBitBtn.Click;
begin

end;

type
  TSpecialImage = class(TImage)
  private
    FOldPictureChanged: TNotifyEvent;
    FTransparentColor: TColor;
    procedure PictureChanged(Sender: TObject);
  protected
    procedure Click; override;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

procedure TSpecialImage.PictureChanged(Sender: TObject);
var
  B: TBitmap;
begin
  if Assigned(FOldPictureChanged) then
    FOldPictureChanged(Sender);

  if Assigned(Picture.Graphic) and Picture.Graphic.Transparent then
  begin
    B := TBitmap.Create;
    try
      B.Height := Picture.Graphic.Height;
      B.Width := Picture.Graphic.Width;
      B.Assign(Picture.Graphic);
      FTransparentColor := B.TransparentColor and not $02000000;
    finally
      B.Free;
    end;
  end
  else
    FTransparentColor := clDefault;
end;

procedure TSpecialImage.Click;
begin

end;

procedure TSpecialImage.WMLButtonUp(var Message: TWMLButtonUp);
var
  P: TPoint;
begin
  inherited;
  if Assigned(Picture.Graphic) then
  begin
    P := SmallPointToPoint(Message.Pos);
    with P do
    begin
      OutputDebugString(PChar(Format('Pixels: %d %s Trans: %d %s',
        [Canvas.Pixels[x, y], ColorToString(Canvas.Pixels[x, y]), FTransparentColor, ColorToString(FTransparentColor)])));

      if PtInRect(ClientRect, P) and (Canvas.Pixels[x, y] <> FTransparentColor) then
        inherited Click;
    end;
  end
  else
    inherited Click;
end;

constructor TSpecialImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOldPictureChanged := Picture.OnChange;
  Picture.OnChange := PictureChanged;
  FTransparentColor := clDefault;
end;

destructor TSpecialImage.Destroy;
begin
  Picture.OnChange := FOldPictureChanged;
  FOldPictureChanged := nil;
  inherited Destroy;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FBtn := TSpecialBitBtn.Create(Self);
  try
    FBtn.Parent := Self;
    FBtn.Kind := bkOK;
    FBtn.Left := 8;
    FBtn.Top := 8;
    FBtn.OnClick := BtnClick;
  except
    FBtn.Free;
    raise;
  end;

  FImage := TSpecialImage.Create(Self);
  try
    FImage.Parent := Self;
    FImage.Left := 8;
    FImage.Top := 40;
    FImage.AutoSize := True;
    FImage.Transparent := True;
    FImage.Picture.LoadFromFile('C:\Program Files\Common Files\Borland Shared\Images\Splash\16Color\Athena.bmp');
    FImage.OnClick := ImageClick;
  except
    FImage.Free;
    raise;
  end;
end;

procedure TForm1.BtnClick(Sender: TObject);
begin
  ShowMessage('click');
end;

procedure TForm1.ImageClick(Sender: TObject);
begin
  ShowMessage('click');
end;

Igor: looking at help for TPicture.Bitmap, I'm not sure if your suggestion will work for other pictures than .bmp...?
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
ITugayCommented:
Ondrej,
seems you are right. Line of code:

    B := Picture.Bitmap;

should be replaced to

    B := TBitmap.Create;
    try
      B.Height := Picture.Graphic.Height;
      B.Width := Picture.Graphic.Width;
      B.Assign(Picture.Graphic);
      if B.Canvas.Pixels[LoWord(M.LParam), HiWord(M.LParam)] =
        (B.TransparentColor and $FFFFFF) then
        M.Result := 0
      else
        Inherited;
    finally
      B.Free;
    end;

----
Igor

0
 
TOndrejCommented:
yep but in that case you're creating/destroying the bitmap on every left button down...
I thought about this too, and decided to only read the value of transparent color when the Picture is changed.
Cheers
0
 
ITugayCommented:
Ondrej,

yes, I have put myself in the trap :-)

0
 
robert_marquardtAuthor Commented:
Sorry, both solutions for TBitBtn are wrong.
The control already has the focus when MouseDown is called and Click is called after MouseDown.

The TImage has to be tested this evening.
0
 
TOndrejCommented:
My solution has nothing to do with MouseDown...
0
 
robert_marquardtAuthor Commented:
Yep. You use Click which is called AFTER MouseDown so the control has the focus already.
So i cannot decide if the click gave the focus or not.
0
 
ITugayCommented:
Hi robert_marquard,

  TMyBitBtn = class(TBitBtn)
  protected
    procedure WndProc(var M: TMessage); override;
  end;

....
procedure TMyBitBtn.WndProc(var M: TMessage);
begin
  case M.Msg of
    WM_LBUTTONDOWN:
      if not Focused then
        SetFocus
      else
        Inherited;
  else
    Inherited
  end;
end;

-------
Igor.
0
 
TOndrejCommented:
A click will always give the focus, there's nothing to decide. Except if the control is already focused then click will not change focus. Am I missing something?

You said:

"The trick is that a left click should only set focus to the control, but should not generate an OnClick
event."

That requirement is met perfectly. No OnClick is generated because inherited Click is never called.

I'm sure I've missed or I don't understand something important here; please try to explain in detail.
0
 
robert_marquardtAuthor Commented:
Yes. Just discovered that i worded it badly.
If not focused then the control should focus without OnClick. Clicking the focused control should give an OnClick.
0
 
TOndrejCommented:
I see now :-)

type
  TSpecialBitBtn = class(TBitBtn)
  private
    FAllowClick: Boolean;
  protected
    procedure Click; override;
    procedure WndProc(var Message: TMessage); override;
  end;

procedure TSpecialBitBtn.Click;
begin
  if FAllowClick then
    inherited Click;
end;

procedure TSpecialBitBtn.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_LBUTTONDOWN then
    FAllowClick := Focused;
  inherited;
end;

Similar to Igor's suggestion but clicks are always shown visually (you see the button depressed and released).

HTH
TOndrej
0
 
ITugayCommented:
Ondrej,

would it be problem if user focused button by [Tab] key?

Cheers,
Igor.

0
 
TOndrejCommented:
Hi Igor :-)
I don't think so, why?
0
 
ITugayCommented:
In this cases FAllowClick will be false, right?
Try to click it by [Space].
:-)
0
 
robert_marquardtAuthor Commented:
No problem with Tab or Space or whatever.
This will be a special button which can show all keys so Tab is disabled anyway. They also focus, but do not click.
Only left mouse button focuses and clicks. The other mouse buttons work already.

I think i will split the points.
0
 
TOndrejCommented:
you're right, Igor :-)

next try:

type
  TSpecialBitBtn = class(TBitBtn)
  private
    FAllowClick: Boolean;
    FMouseFocus: Boolean;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  protected
    procedure Click; override;
    procedure WndProc(var Message: TMessage); override;
  end;

procedure TSpecialBitBtn.CMEnter(var Message: TCMEnter);
begin
  FAllowClick := not FMouseFocus;
  FMouseFocus := False;
  inherited;
end;

procedure TSpecialBitBtn.Click;
begin
  if FAllowClick then
    inherited Click;
  FAllowClick := True;
end;

procedure TSpecialBitBtn.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_LBUTTONDOWN then
  begin
    FMouseFocus := not Focused;
    FAllowClick := Focused;
  end;
  inherited;
end;
0
 
ITugayCommented:
Ondrej,
yes, it is:-)

Robert,
glad to help you.



0
 
robert_marquardtAuthor Commented:
Here is the result of my tests for the special TImage.
The points go to ITugay because his first answer near.
For the special TbitBtn i will do more tests and set up a "points for" question if my solution is inspired by one of the comments here.

type
  TMyImage = class(TImage)
  private
    procedure WMLButtonDown(var Msg: TWMMouse); message WM_LBUTTONDOWN;
  end;

procedure Register;

implementation

procedure TMyImage.WMLButtonDown(var Msg: TWMMouse);
begin
  if Assigned(Picture) and Assigned(Picture.Bitmap) and Picture.Bitmap.Transparent and
    (Msg.XPos < Picture.Bitmap.Width) and (Msg.YPos < Picture.Bitmap.Height) and
    (Picture.Bitmap.Canvas.Pixels[Msg.XPos, Msg.YPos] <> (Picture.Bitmap.TransparentColor and $FFFFFF)) then
    inherited;
end;
0
 
robert_marquardtAuthor Commented:
I just discovered the it is even better to use CM_HITTEST instead of WM_LBUTTONDOWN. Same code as above.
That handles overlapping TMyImages which is important for me.
0
 
TOndrejCommented:
I'm not sure but not calling inherited WMLButtonDown could possibly have undesired side effects; I had the impression that it's recommended to never suppress mouse button messages; IIRC csClicked is set and cleared somewhere down the ancestry chain; and my suggestion also seems cleaner to me.
CM_HITTEST is IMHO an excellent idea; it seems indeed ideal for this purpose.
Cheers
TOndrej
0
 
ITugayCommented:
I agree that CM_HITTEST is better then WN_LBUTTONDOWN.
Ondrej is right about calling Inherited for mouse buttons events. They occurs in pair "down & up", and some flags may be set inside control. But usually nothing happen if inherit call skipped. Anyway, Message.Result should be assigned.

----
Igor
0
 
robert_marquardtAuthor Commented:
I finetuned again. Now inherited is called always (which sets Msg.Result) and then Msg.Result is changed with the test. This should be the safest way possible.

inherited;
if Assigned(Picture) and Assigned(Picture.Bitmap) and Picture.Bitmap.Transparent and
   (Msg.XPos < Picture.Bitmap.Width) and (Msg.YPos < Picture.Bitmap.Height) and
   (Picture.Bitmap.Canvas.Pixels[Msg.XPos, Msg.YPos] = (Picture.Bitmap.TransparentColor and $FFFFFF))
then
   Msg.Result := 0;
0
 
ITugayCommented:
something like this.
Just a note. In some cases Inherited can change value of WParam and LParam, be carefull :-)

-----
Igor.
0
 
robert_marquardtAuthor Commented:
I got a hint for mouse activate which was not mentioned here. So no split points if that way will work.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 9
  • 8
  • 8
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now